From 537e5ee688b42ccd87ac1e90165d2af97bcd71b7 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Thu, 14 Jun 2018 13:30:11 -0700 Subject: [PATCH] Updated make_expect.pl to view results with vim --- t/snippets/expect/rt18318.def | 4 + t/snippets/expect/rt18318.rt18318 | 4 + t/snippets/make_expect.pl | 61 +++++++++- t/snippets/rt18318.in | 4 + t/snippets/rt18318.par | 1 + t/snippets1.t | 2 +- t/snippets10.t | 178 ++++++++++++---------------- t/snippets11.t | 187 +++++++++++++++++------------- t/snippets12.t | 112 ++++++++++++------ t/snippets2.t | 2 +- t/snippets3.t | 2 +- t/snippets4.t | 2 +- t/snippets5.t | 2 +- t/snippets6.t | 2 +- t/snippets7.t | 2 +- t/snippets8.t | 106 ++++++++--------- t/snippets9.t | 143 ++++++++++++----------- 17 files changed, 458 insertions(+), 356 deletions(-) create mode 100644 t/snippets/expect/rt18318.def create mode 100644 t/snippets/expect/rt18318.rt18318 create mode 100644 t/snippets/rt18318.in create mode 100644 t/snippets/rt18318.par diff --git a/t/snippets/expect/rt18318.def b/t/snippets/expect/rt18318.def new file mode 100644 index 00000000..1ed599fa --- /dev/null +++ b/t/snippets/expect/rt18318.def @@ -0,0 +1,4 @@ +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of : ATTR( :init_arg :get :set ); diff --git a/t/snippets/expect/rt18318.rt18318 b/t/snippets/expect/rt18318.rt18318 new file mode 100644 index 00000000..21222b60 --- /dev/null +++ b/t/snippets/expect/rt18318.rt18318 @@ -0,0 +1,4 @@ +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of :ATTR( :init_arg :get :set ); diff --git a/t/snippets/make_expect.pl b/t/snippets/make_expect.pl index 8e2da110..8fa64101 100755 --- a/t/snippets/make_expect.pl +++ b/t/snippets/make_expect.pl @@ -184,7 +184,9 @@ foreach my $basename (@olist) { my $tname = $opath . $basename; my $ename = $epath . $basename; if ( !-e $ename ) { - print "tmp/$basename is a new file\n"; + my $new_file = "tmp/$basename"; + push @new, $new_file; + print "$new_file is a new file\n"; push @mv, "cp $tname $ename"; } elsif ( compare( $ename, $tname ) ) { @@ -243,14 +245,67 @@ EOM close RUN; system("chmod 0755 $runme"); + + if (@new) { + if ( + ifyes( +"You need to review the new tidied files. Do you want to look at them now? [Y/N]" + ) + ) + { + my $str = join " ", @new; + system("vim -R $str"); + } + } + + if ( -e $diff_file ) { + if ( + ifyes( +"There are differences between the old and new tidied results.\nDo you want to look at them now? [Y/N]" + ) + ) + { + system("vim -R $diff_file"); + } + } + + my $diff_msg = -e $diff_file ? "Look at differences in '$diff_file'" : "no differences"; + print <; + chomp $ans; + #my $val=$ans; + return $ans; +} +sub ifyes { + + # Updated to have default, which should be "Y" or "N" + my ($msg, $default)=@_; + my $count = 0; + ASK: + my $ans = query($msg); + if ( defined($default) ) { + $ans = $default unless ($ans); + } + if ( $ans =~ /^Y/i ) { return 1 } + elsif ( $ans =~ /^N/i ) { return 0 } + else { + $count++; + if ( $count > 6 ) { die "error count exceeded in ifyes\n" } + print STDERR "Please answer 'Y' or 'N'\n"; + goto ASK; + } +} diff --git a/t/snippets/rt18318.in b/t/snippets/rt18318.in new file mode 100644 index 00000000..1ed599fa --- /dev/null +++ b/t/snippets/rt18318.in @@ -0,0 +1,4 @@ +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of : ATTR( :init_arg :get :set ); diff --git a/t/snippets/rt18318.par b/t/snippets/rt18318.par new file mode 100644 index 00000000..fd5318ab --- /dev/null +++ b/t/snippets/rt18318.par @@ -0,0 +1 @@ +-nwrs='A' diff --git a/t/snippets1.t b/t/snippets1.t index b2837b90..fae1e0b4 100644 --- a/t/snippets1.t +++ b/t/snippets1.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:23 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets10.t b/t/snippets10.t index 610b287e..b02b42fd 100644 --- a/t/snippets10.t +++ b/t/snippets10.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' @@ -19,6 +19,7 @@ BEGIN { ##################################### $rparams = { 'def' => "", + 'scl' => "-scl=12", 'sil' => "-sil=0", 'style1' => <<'----------', -b @@ -116,6 +117,16 @@ BEGIN { ###################### $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 @@ -357,36 +368,6 @@ sub doit{print"Hello package\n";}package sub; sub doit{print"Hello sub\n";}package __END__; sub doit{print"Hello __END__\n";}package __DATA__; sub doit{print"Hello __DATA__\n";} ----------- - - 'sub2' => <<'----------', -my $selector; - -# leading atrribute separator: -$a = - sub - : locked { - print "Hello, World!\n"; - }; -$a->(); - -# colon as both ?/: and attribute separator -$a = $selector - ? sub : locked { - print "Hello, World!\n"; - } - : sub : locked { - print "GOODBYE!\n"; - }; -$a->(); ----------- - - 'switch1' => <<'----------', -sub classify_digit($digit) - { switch($digit) - { case 0 { return 'zero' } case [ 2, 4, 6, 8 ]{ return 'even' } - case [ 1, 3, 4, 7, 9 ]{ return 'odd' } case /[A-F]/i { return 'hex' } } - } ---------- }; @@ -395,10 +376,35 @@ sub classify_digit($digit) ############################## $rtests = { + 'scl.scl' => { + source => "scl", + params => "scl", + 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........... + }, + + 'semicolon2.def' => { + source => "semicolon2", + params => "def", + expect => <<'#2...........', + # will not add semicolon for this block type + $highest = List::Util::reduce { + Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b + } +#2........... + }, + 'side_comments1.def' => { source => "side_comments1", params => "def", - expect => <<'#1...........', + expect => <<'#3...........', # side comments at different indentation levels should not be aligned { { @@ -409,13 +415,13 @@ sub classify_digit($digit) } # end level 3 } # end level 2 } # end level 1 -#1........... +#3........... }, 'sil1.def' => { source => "sil1", params => "def", - expect => <<'#2...........', + expect => <<'#4...........', ############################################################# # This will walk to the left because of bad -sil guess SKIP: { @@ -429,13 +435,13 @@ sub classify_digit($digit) or ov_method mycan( $package, '(bool' ), $package or ov_method mycan( $package, '(nomethod' ), $package; -#2........... +#4........... }, 'sil1.sil' => { source => "sil1", params => "sil", - expect => <<'#3...........', + expect => <<'#5...........', ############################################################# # This will walk to the left because of bad -sil guess SKIP: { @@ -449,13 +455,13 @@ SKIP: { or ov_method mycan( $package, '(bool' ), $package or ov_method mycan( $package, '(nomethod' ), $package; -#3........... +#5........... }, 'slashslash.def' => { source => "slashslash", params => "def", - expect => <<'#4...........', + expect => <<'#6...........', $home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7] // die "You're homeless!\n"; defined( $x // $y ); @@ -463,13 +469,13 @@ $version = 'v' . join '.', map ord, split //, $version->PV; foreach ( split( //, $lets ) ) { } foreach ( split( //, $input ) ) { } 'xyz' =~ //; -#4........... +#6........... }, 'smart.def' => { source => "smart", params => "def", - expect => <<'#5...........', + expect => <<'#7...........', \&foo !~~ \&foo; \&foo ~~ \&foo; \&foo ~~ \&foo; @@ -582,13 +588,13 @@ qr/3/ ~~ 12345; "foo" ~~ %hash; %hash ~~ /bar/; /bar/ ~~ %hash; -#5........... +#7........... }, 'space1.def' => { source => "space1", params => "def", - expect => <<'#6...........', + expect => <<'#8...........', # We usually want a space at '} (', for example: map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s ); @@ -597,60 +603,60 @@ qr/3/ ~~ 12345; # remove unwanted spaces after $ and -> here &{ $_->[1] }( delete $_[$#_]{ $_->[0] } ); -#6........... +#8........... }, 'space2.def' => { source => "space2", params => "def", - expect => <<'#7...........', + expect => <<'#9...........', # space before this opening paren for $i ( 0 .. 20 ) { } # retain any space between '-' and bare word $myhash{ USER-NAME } = 'steve'; -#7........... +#9........... }, 'space3.def' => { source => "space3", params => "def", - expect => <<'#8...........', + expect => <<'#10...........', # Treat newline as a whitespace. Otherwise, we might combine # 'Send' and '-recipients' here my $msg = new Fax::Send -recipients => $to, -data => $data; -#8........... +#10........... }, 'space4.def' => { source => "space4", params => "def", - expect => <<'#9...........', + expect => <<'#11...........', # 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/'); -#9........... +#11........... }, 'space5.def' => { source => "space5", params => "def", - expect => <<'#10...........', + expect => <<'#12...........', # first prototype line commented out; space after 'redirect' remains #sub html::redirect($); #<-- temporary prototype; use html; print html::redirect ('http://www.glob.com.au/'); -#10........... +#12........... }, 'structure1.def' => { source => "structure1", params => "def", - expect => <<'#11...........', + expect => <<'#13...........', push @contents, $c->table( { -width => '100%' }, @@ -669,13 +675,13 @@ push @contents, ) ) ); -#11........... +#13........... }, 'style.def' => { source => "style", params => "def", - expect => <<'#12...........', + expect => <<'#14...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { my (@order) = ( @@ -721,13 +727,13 @@ sub arrange_topframe { } } -#12........... +#14........... }, 'style.style1' => { source => "style", params => "style1", - expect => <<'#13...........', + expect => <<'#15...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { my (@order) = ( @@ -766,13 +772,13 @@ sub arrange_topframe { } } -#13........... +#15........... }, 'style.style2' => { source => "style", params => "style2", - expect => <<'#14...........', + expect => <<'#16...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { my (@order) = ( @@ -814,13 +820,13 @@ sub arrange_topframe { } } -#14........... +#16........... }, 'style.style3' => { source => "style", params => "style3", - expect => <<'#15...........', + expect => <<'#17...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { my (@order) = ( @@ -858,13 +864,13 @@ sub arrange_topframe { } } ## end sub arrange_topframe -#15........... +#17........... }, 'style.style4' => { source => "style", params => "style4", - expect => <<'#16...........', + expect => <<'#18...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { my (@order) = ( @@ -906,13 +912,13 @@ sub arrange_topframe { } } -#16........... +#18........... }, 'style.style5' => { source => "style", params => "style5", - expect => <<'#17...........', + expect => <<'#19...........', # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence sub arrange_topframe { @@ -958,13 +964,13 @@ sub arrange_topframe } } -#17........... +#19........... }, 'sub1.def' => { source => "sub1", params => "def", - expect => <<'#18...........', + expect => <<'#20...........', my::doit(); join::doit(); for::doit(); @@ -993,46 +999,6 @@ sub doit { print "Hello __END__\n"; } package __DATA__; sub doit { print "Hello __DATA__\n"; } -#18........... - }, - - 'sub2.def' => { - source => "sub2", - params => "def", - expect => <<'#19...........', -my $selector; - -# leading atrribute separator: -$a = sub - : locked { - print "Hello, World!\n"; - }; -$a->(); - -# colon as both ?/: and attribute separator -$a = $selector - ? sub : locked { - print "Hello, World!\n"; - } - : sub : locked { - print "GOODBYE!\n"; - }; -$a->(); -#19........... - }, - - 'switch1.def' => { - source => "switch1", - params => "def", - expect => <<'#20...........', -sub classify_digit($digit) { - switch ($digit) { - case 0 { return 'zero' } - case [ 2, 4, 6, 8 ]{ return 'even' } - case [ 1, 3, 4, 7, 9 ]{ return 'odd' } - case /[A-F]/i { return 'hex' } - } -} #20........... }, }; diff --git a/t/snippets11.t b/t/snippets11.t index 1bed45ad..a2e5c356 100644 --- a/t/snippets11.t +++ b/t/snippets11.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:35 2018 # To locate test #13 for example, search for the string '#13' @@ -26,11 +26,6 @@ BEGIN { -bt=2 -pt=2 -sbt=2 ----------- - 'vtc' => <<'----------', --sbvtc=2 --bvtc=2 --pvtc=2 ---------- }; @@ -39,6 +34,36 @@ BEGIN { ###################### $rsources = { + 'sub2' => <<'----------', +my $selector; + +# leading atrribute separator: +$a = + sub + : locked { + print "Hello, World!\n"; + }; +$a->(); + +# colon as both ?/: and attribute separator +$a = $selector + ? sub : locked { + print "Hello, World!\n"; + } + : sub : locked { + print "GOODBYE!\n"; + }; +$a->(); +---------- + + 'switch1' => <<'----------', +sub classify_digit($digit) + { switch($digit) + { case 0 { return 'zero' } case [ 2, 4, 6, 8 ]{ return 'even' } + case [ 1, 3, 4, 7, 9 ]{ return 'odd' } case /[A-F]/i { return 'hex' } } + } +---------- + 'syntax1' => <<'----------', # Caused trouble: print $x **2; @@ -167,16 +192,6 @@ sub Restore { 'The Shire', undef], ); ---------- - - 'vtc2' => <<'----------', - ok( - $s->call( - SOAP::Data->name('getStateName') - ->attr( { xmlns => 'urn:/My/Examples' } ), - 1 - )->result eq 'Alabama' - ); ----------- }; ############################## @@ -184,28 +199,68 @@ sub Restore { ############################## $rtests = { + 'sub2.def' => { + source => "sub2", + params => "def", + expect => <<'#1...........', +my $selector; + +# leading atrribute separator: +$a = sub + : locked { + print "Hello, World!\n"; + }; +$a->(); + +# colon as both ?/: and attribute separator +$a = $selector + ? sub : locked { + print "Hello, World!\n"; + } + : sub : locked { + print "GOODBYE!\n"; + }; +$a->(); +#1........... + }, + + 'switch1.def' => { + source => "switch1", + params => "def", + expect => <<'#2...........', +sub classify_digit($digit) { + switch ($digit) { + case 0 { return 'zero' } + case [ 2, 4, 6, 8 ]{ return 'even' } + case [ 1, 3, 4, 7, 9 ]{ return 'odd' } + case /[A-F]/i { return 'hex' } + } +} +#2........... + }, + 'syntax1.def' => { source => "syntax1", params => "def", - expect => <<'#1...........', + expect => <<'#3...........', # Caused trouble: print $x **2; -#1........... +#3........... }, 'syntax2.def' => { source => "syntax2", params => "def", - expect => <<'#2...........', + expect => <<'#4...........', # ? was taken as pattern my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; -#2........... +#4........... }, 'ternary1.def' => { source => "ternary1", params => "def", - expect => <<'#3...........', + expect => <<'#5...........', my $flags = ( $_ & 1 ) ? ( $_ & 4 ) @@ -213,13 +268,13 @@ my $flags = : $THRf_ZOMBIE : ( $_ & 4 ) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; -#3........... +#5........... }, 'ternary2.def' => { source => "ternary2", params => "def", - expect => <<'#4...........', + expect => <<'#6...........', my $a = ($b) ? ($c) @@ -233,13 +288,13 @@ my $a = : $g2 : ($h) ? $h1 : $h2; -#4........... +#6........... }, 'tick1.def' => { source => "tick1", params => "def", - expect => <<'#5...........', + expect => <<'#7...........', sub a'this { $p'u'a = "mooo\n"; print $p::u::a; } a::this(); # print "mooo" print $p'u'a; # print "mooo" @@ -253,42 +308,42 @@ $a'that->(); # print "wwoo" $a'that = a'that(); $p::t::u = "booo\n"; $a'that->(); # print "booo" -#5........... +#7........... }, 'trim_quote.def' => { source => "trim_quote", params => "def", - expect => <<'#6...........', + expect => <<'#8...........', # space after quote will get trimmed push @m, ' all :: pure_all manifypods ' . $self->{NOECHO} . '$(NOOP) ' unless $self->{SKIPHASH}{'all'}; -#6........... +#8........... }, 'tso1.def' => { source => "tso1", params => "def", - expect => <<'#7...........', + expect => <<'#9...........', print 0 + '42 EUR'; # 42 -#7........... +#9........... }, 'tso1.tso' => { source => "tso1", params => "tso", - expect => <<'#8...........', + expect => <<'#10...........', print 0+ '42 EUR'; # 42 -#8........... +#10........... }, 'tutor.def' => { source => "tutor", params => "def", - expect => <<'#9...........', + expect => <<'#11...........', #!/usr/bin/perl $y = shift || 5; for $i ( 1 .. 10 ) { $l[$i] = "T"; $w[$i] = 999999; } @@ -326,24 +381,24 @@ while (1) { print $l[$i], "\t", $w[$i], "\r\n"; } } -#9........... +#11........... }, 'undoci1.def' => { source => "undoci1", params => "def", - expect => <<'#10...........', + expect => <<'#12...........', $rinfo{deleteStyle} = [ -fill => 'red', -stipple => '@' . Tk->findINC('demos/images/grey.25'), ]; -#10........... +#12........... }, 'use1.def' => { source => "use1", params => "def", - expect => <<'#11...........', + expect => <<'#13...........', # previously this caused an incorrect error message after '2.42' use lib "$Common::global::gInstallRoot/lib"; use CGI 2.42 qw(fatalsToBrowser); @@ -353,44 +408,44 @@ use RRDs 1.000101; use constant MODE => do { 0666 & ( 0777 & ~umask ) }; use IO::File (); -#11........... +#13........... }, 'use2.def' => { source => "use2", params => "def", - expect => <<'#12...........', + expect => <<'#14...........', # Keep the space before the '()' here: use Foo::Bar (); use Foo::Bar (); use Foo::Bar 1.0 (); use Foo::Bar qw(baz); use Foo::Bar 1.0 qw(baz); -#12........... +#14........... }, 'version1.def' => { source => "version1", params => "def", - expect => <<'#13...........', + expect => <<'#15...........', # VERSION statement unbroken, no semicolon added; our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r } -#13........... +#15........... }, 'version2.def' => { source => "version2", params => "def", - expect => <<'#14...........', + expect => <<'#16...........', # On one line so MakeMaker will see it. require Exporter; our $VERSION = $Exporter::VERSION; -#14........... +#16........... }, 'vert.def' => { source => "vert", params => "def", - expect => <<'#15...........', + expect => <<'#17...........', # if $w->vert is tokenized as type 'U' then the ? will start a quote # and an error will occur. sub vert { @@ -399,13 +454,13 @@ sub vert { sub Restore { $w->vert ? $w->delta_width(0) : $w->delta_height(0); } -#15........... +#17........... }, 'vmll.def' => { source => "vmll", params => "def", - expect => <<'#16...........', + expect => <<'#18...........', # perltidy -act=2 -vmll will leave these intact and greater than 80 columns # in length, which is what vmll does BEGIN { @@ -416,13 +471,13 @@ sub Restore { This has the comma on the next line exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, -#16........... +#18........... }, 'vmll.vmll' => { source => "vmll", params => "vmll", - expect => <<'#17...........', + expect => <<'#19...........', # perltidy -act=2 -vmll will leave these intact and greater than 80 columns # in length, which is what vmll does BEGIN {is_deeply(\@init_metas_called, [1]) || diag(Dumper(\@init_metas_called))} @@ -430,13 +485,13 @@ sub Restore { This has the comma on the next line exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, -#17........... +#19........... }, 'vtc1.def' => { source => "vtc1", params => "def", - expect => <<'#18...........', + expect => <<'#20...........', @lol = ( [ 'Dr. Watson', undef, '221b', 'Baker St.', @@ -449,36 +504,6 @@ sub Restore { 'The Shire', undef ], ); -#18........... - }, - - 'vtc1.vtc' => { - source => "vtc1", - params => "vtc", - expect => <<'#19...........', -@lol = ( - [ - 'Dr. Watson', undef, '221b', 'Baker St.', - undef, 'London', 'NW1', undef, - 'England', undef ], - [ - 'Sam Gamgee', undef, undef, 'Bagshot Row', - undef, 'Hobbiton', undef, undef, - 'The Shire', undef ], ); -#19........... - }, - - 'vtc2.def' => { - source => "vtc2", - params => "def", - expect => <<'#20...........', - ok( - $s->call( - SOAP::Data->name('getStateName') - ->attr( { xmlns => 'urn:/My/Examples' } ), - 1 - )->result eq 'Alabama' - ); #20........... }, }; diff --git a/t/snippets12.t b/t/snippets12.t index d1a93664..722f21ee 100644 --- a/t/snippets12.t +++ b/t/snippets12.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:35 2018 # To locate test #13 for example, search for the string '#13' @@ -32,6 +32,18 @@ BEGIN { ###################### $rsources = { + 'vtc1' => <<'----------', +@lol = ( + [ 'Dr. Watson', undef, '221b', 'Baker St.', + undef, 'London', 'NW1', undef, + 'England', undef + ], + [ 'Sam Gamgee', undef, undef, 'Bagshot Row', + undef, 'Hobbiton', undef, undef, + 'The Shire', undef], + ); +---------- + 'vtc2' => <<'----------', ok( $s->call( @@ -154,43 +166,73 @@ use_all_ok( ############################## $rtests = { + 'vtc1.vtc' => { + source => "vtc1", + params => "vtc", + expect => <<'#1...........', +@lol = ( + [ + 'Dr. Watson', undef, '221b', 'Baker St.', + undef, 'London', 'NW1', undef, + 'England', undef ], + [ + 'Sam Gamgee', undef, undef, 'Bagshot Row', + undef, 'Hobbiton', undef, undef, + 'The Shire', undef ], ); +#1........... + }, + + 'vtc2.def' => { + source => "vtc2", + params => "def", + expect => <<'#2...........', + ok( + $s->call( + SOAP::Data->name('getStateName') + ->attr( { xmlns => 'urn:/My/Examples' } ), + 1 + )->result eq 'Alabama' + ); +#2........... + }, + 'vtc2.vtc' => { source => "vtc2", params => "vtc", - expect => <<'#1...........', + expect => <<'#3...........', ok( $s->call( SOAP::Data->name('getStateName') ->attr( { xmlns => 'urn:/My/Examples' } ), 1 )->result eq 'Alabama' ); -#1........... +#3........... }, 'vtc3.def' => { source => "vtc3", params => "def", - expect => <<'#2...........', + expect => <<'#4...........', $day_long = ( "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" )[$wday]; -#2........... +#4........... }, 'vtc3.vtc' => { source => "vtc3", params => "vtc", - expect => <<'#3...........', + expect => <<'#5...........', $day_long = ( "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" )[$wday]; -#3........... +#5........... }, 'vtc4.def' => { source => "vtc4", params => "def", - expect => <<'#4...........', + expect => <<'#6...........', my $bg_color = $im->colorAllocate( unpack( 'C3', @@ -207,13 +249,13 @@ my $bg_color = $im->colorAllocate( ) ) ); -#4........... +#6........... }, 'vtc4.vtc' => { source => "vtc4", params => "vtc", - expect => <<'#5...........', + expect => <<'#7...........', my $bg_color = $im->colorAllocate( unpack( 'C3', @@ -225,13 +267,13 @@ my $bg_color = $im->colorAllocate( length( $options_r->{'bg_color'} ) ? $options_r->{'bg_color'} : $MIDI::Opus::BG_color ) ) ) ) ); -#5........... +#7........... }, 'wn1.def' => { source => "wn1", params => "def", - expect => <<'#6...........', + expect => <<'#8...........', my $bg_color = $im->colorAllocate( unpack( 'C3', @@ -248,13 +290,13 @@ my $bg_color = $im->colorAllocate( ) ) ); -#6........... +#8........... }, 'wn1.wn' => { source => "wn1", params => "wn", - expect => <<'#7...........', + expect => <<'#9...........', my $bg_color = $im->colorAllocate( unpack( 'C3', pack( @@ -269,13 +311,13 @@ my $bg_color = $im->colorAllocate( ) ) ) ); -#7........... +#9........... }, 'wn2.def' => { source => "wn2", params => "def", - expect => <<'#8...........', + expect => <<'#10...........', if ( $PLATFORM eq 'aix' ) { skip_symbols( [ @@ -288,13 +330,13 @@ if ( $PLATFORM eq 'aix' ) { ] ); } -#8........... +#10........... }, 'wn2.wn' => { source => "wn2", params => "wn", - expect => <<'#9...........', + expect => <<'#11...........', if ( $PLATFORM eq 'aix' ) { skip_symbols( [ qw( Perl_dump_fds @@ -303,13 +345,13 @@ if ( $PLATFORM eq 'aix' ) { PL_sys_intern ) ] ); } -#9........... +#11........... }, 'wn3.def' => { source => "wn3", params => "def", - expect => <<'#10...........', + expect => <<'#12...........', deferred->resolve->then( sub { push @out, 'Resolve'; @@ -321,13 +363,13 @@ deferred->resolve->then( push @out, @_; } ); -#10........... +#12........... }, 'wn3.wn' => { source => "wn3", params => "wn", - expect => <<'#11...........', + expect => <<'#13...........', deferred->resolve->then( sub { push @out, 'Resolve'; return $then; @@ -335,13 +377,13 @@ deferred->resolve->then( sub { push @out, 'Reject'; push @out, @_; } ); -#11........... +#13........... }, 'wn4.def' => { source => "wn4", params => "def", - expect => <<'#12...........', + expect => <<'#14...........', { { { @@ -355,13 +397,13 @@ deferred->resolve->then( sub { } } } -#12........... +#14........... }, 'wn4.wn' => { source => "wn4", params => "wn", - expect => <<'#13...........', + expect => <<'#15...........', { { { # Orignal formatting looks nice but would be hard to duplicate @@ -371,13 +413,13 @@ deferred->resolve->then( sub { ? %{ $G->{Attr}->{E}->{$u}->{$v} } : (); } } } -#13........... +#15........... }, 'wn5.def' => { source => "wn5", params => "def", - expect => <<'#14...........', + expect => <<'#16...........', # qw weld with -wn use_all_ok( qw{ @@ -391,13 +433,13 @@ use_all_ok( PPI::Cache } ); -#14........... +#16........... }, 'wn5.wn' => { source => "wn5", params => "wn", - expect => <<'#15...........', + expect => <<'#17...........', # qw weld with -wn use_all_ok( qw{ PPI @@ -409,13 +451,13 @@ use_all_ok( qw{ PPI::Util PPI::Cache } ); -#15........... +#17........... }, 'wn6.def' => { source => "wn6", params => "def", - expect => <<'#16...........', + expect => <<'#18...........', # illustration of some do-not-weld rules # do not weld a two-line function call @@ -447,13 +489,13 @@ use_all_ok( qw{ $_[0]->(); } ); -#16........... +#18........... }, 'wn6.wn' => { source => "wn6", params => "wn", - expect => <<'#17...........', + expect => <<'#19...........', # illustration of some do-not-weld rules # do not weld a two-line function call @@ -479,7 +521,7 @@ use_all_ok( qw{ push @tracelog => 'around 1'; $_[0]->(); } ); -#17........... +#19........... }, }; diff --git a/t/snippets2.t b/t/snippets2.t index 66b7fc31..70b066c4 100644 --- a/t/snippets2.t +++ b/t/snippets2.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets3.t b/t/snippets3.t index f016401f..f3bcc92d 100644 --- a/t/snippets3.t +++ b/t/snippets3.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets4.t b/t/snippets4.t index a1e3e871..60989670 100644 --- a/t/snippets4.t +++ b/t/snippets4.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets5.t b/t/snippets5.t index 3419b8a7..e2dab826 100644 --- a/t/snippets5.t +++ b/t/snippets5.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets6.t b/t/snippets6.t index fb3bcad4..8238c502 100644 --- a/t/snippets6.t +++ b/t/snippets6.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets7.t b/t/snippets7.t index ecf5ac39..4a6e4092 100644 --- a/t/snippets7.t +++ b/t/snippets7.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' diff --git a/t/snippets8.t b/t/snippets8.t index eb3d6cea..5c23ffeb 100644 --- a/t/snippets8.t +++ b/t/snippets8.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' @@ -26,7 +26,10 @@ BEGIN { -dac ---------- 'rt125506' => "-io", - 'rt50702' => <<'----------', + 'rt18318' => <<'----------', +-nwrs='A' +---------- + 'rt50702' => <<'----------', -wbb='=' ---------- 'rt70747' => "-i=2", @@ -107,6 +110,13 @@ my $t = ' 'rt15735' => <<'----------', my $user_prefs = $ref_type eq 'SCALAR' ? _load_from_string( $profile ) : $ref_type eq 'ARRAY' ? _load_from_array( $profile ) : $ref_type eq 'HASH' ? _load_from_hash( $profile ) : _load_from_file( $profile ); +---------- + + 'rt18318' => <<'----------', +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of : ATTR( :init_arg :get :set ); ---------- 'rt27000' => <<'----------', @@ -145,22 +155,6 @@ coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { } @$_; ] }; ----------- - - 'rt74856' => <<'----------', -{ -my $foo = '1'; -#<<< -my $bar = (test()) - ? 'some value' - : undef; -#>>> -my $baz = 'something else'; -} ----------- - - 'rt78156' => <<'----------', -package Some::Class 2.012; ---------- }; @@ -306,10 +300,32 @@ my $user_prefs = #10........... }, + 'rt18318.def' => { + source => "rt18318", + params => "def", + expect => <<'#11...........', +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of : ATTR( :init_arg :get :set ); +#11........... + }, + + 'rt18318.rt18318' => { + source => "rt18318", + params => "rt18318", + expect => <<'#12...........', +# Class::Std attribute list +# The token type of the first colon is 'A' so use -nwrs='A' to avoid space +# after it +my %rank_of :ATTR( :init_arg :get :set ); +#12........... + }, + 'rt27000.def' => { source => "rt27000", params => "def", - expect => <<'#11...........', + expect => <<'#13...........', print add( 3, 4 ), "\n"; print add( 4, 3 ), "\n"; @@ -319,29 +335,29 @@ sub add { die "$term1 > $term2" if $term1 > $term2; return $term1 + $term2; } -#11........... +#13........... }, 'rt31741.def' => { source => "rt31741", params => "def", - expect => <<'#12...........', + expect => <<'#14...........', $msg //= 'World'; -#12........... +#14........... }, 'rt49289.def' => { source => "rt49289", params => "def", - expect => <<'#13...........', + expect => <<'#15...........', use constant qw{ DEBUG 0 }; -#13........... +#15........... }, 'rt50702.def' => { source => "rt50702", params => "def", - expect => <<'#14...........', + expect => <<'#16...........', if (1) { my $uid = $ENV{'ORIG_LOGNAME'} @@ -356,13 +372,13 @@ if (2) { || $ENV{'REMOTE_USER'} || 'foobar' ); } -#14........... +#16........... }, 'rt50702.rt50702' => { source => "rt50702", params => "rt50702", - expect => <<'#15...........', + expect => <<'#17...........', if (1) { my $uid = $ENV{'ORIG_LOGNAME'} @@ -377,21 +393,21 @@ if (2) { || $ENV{'REMOTE_USER'} || 'foobar' ); } -#15........... +#17........... }, 'rt68870.def' => { source => "rt68870", params => "def", - expect => <<'#16...........', + expect => <<'#18...........', s///r; -#16........... +#18........... }, 'rt70747.def' => { source => "rt70747", params => "def", - expect => <<'#17...........', + expect => <<'#19...........', coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { [ map { @@ -401,13 +417,13 @@ coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { } @$_; ] }; -#17........... +#19........... }, 'rt70747.rt70747' => { source => "rt70747", params => "rt70747", - expect => <<'#18...........', + expect => <<'#20...........', coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { [ map { @@ -417,30 +433,6 @@ coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { } @$_; ] }; -#18........... - }, - - 'rt74856.def' => { - source => "rt74856", - params => "def", - expect => <<'#19...........', -{ - my $foo = '1'; -#<<< -my $bar = (test()) - ? 'some value' - : undef; -#>>> - my $baz = 'something else'; -} -#19........... - }, - - 'rt78156.def' => { - source => "rt78156", - params => "def", - expect => <<'#20...........', -package Some::Class 2.012; #20........... }, }; diff --git a/t/snippets9.t b/t/snippets9.t index deb0b908..1e17e633 100644 --- a/t/snippets9.t +++ b/t/snippets9.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Tue Jun 12 19:09:24 2018 +# Thu Jun 14 13:29:34 2018 # To locate test #13 for example, search for the string '#13' @@ -24,7 +24,6 @@ BEGIN { -act=2 ---------- 'rt98902' => "-boc", - 'scl' => "-scl=12", }; ###################### @@ -32,6 +31,22 @@ BEGIN { ###################### $rsources = { + 'rt74856' => <<'----------', +{ +my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> +my $baz = 'something else'; +} +---------- + + 'rt78156' => <<'----------', +package Some::Class 2.012; +---------- + 'rt78764' => <<'----------', qr/3/ ~~ ['1234'] ? 1 : 0; map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; @@ -157,11 +172,6 @@ padding => ( ' ' x $_ ), # 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 } ----------- }; ############################## @@ -169,19 +179,43 @@ padding => ( ' ' x $_ ), ############################## $rtests = { + 'rt74856.def' => { + source => "rt74856", + params => "def", + expect => <<'#1...........', +{ + my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> + my $baz = 'something else'; +} +#1........... + }, + + 'rt78156.def' => { + source => "rt78156", + params => "def", + expect => <<'#2...........', +package Some::Class 2.012; +#2........... + }, + 'rt78764.def' => { source => "rt78764", params => "def", - expect => <<'#1...........', + expect => <<'#3...........', qr/3/ ~~ ['1234'] ? 1 : 0; map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; -#1........... +#3........... }, 'rt79813.def' => { source => "rt79813", params => "def", - expect => <<'#2...........', + expect => <<'#4...........', my %hash = ( a => { bbbbbbbbb => { @@ -189,113 +223,113 @@ my %hash = ( }, }, ); -#2........... +#4........... }, 'rt79947.def' => { source => "rt79947", params => "def", - expect => <<'#3...........', + expect => <<'#5...........', try { croak "An Error!"; } catch ($error) { print STDERR $error . "\n"; } -#3........... +#5........... }, 'rt80645.def' => { source => "rt80645", params => "def", - expect => <<'#4...........', + expect => <<'#6...........', BEGIN { $^W = 1; } use warnings; use strict; @$ = 'test'; print $#{$}; -#4........... +#6........... }, 'rt81852.def' => { source => "rt81852", params => "def", - expect => <<'#5...........', + expect => <<'#7...........', do { { next if ( $n % 2 ); print $n, "\n"; } } while ( $n++ < 10 ); -#5........... +#7........... }, 'rt81852.rt81852' => { source => "rt81852", params => "rt81852", - expect => <<'#6...........', + expect => <<'#8...........', do {{ next if ($n % 2); print $n, "\n"; }} while ($n++ < 10); -#6........... +#8........... }, 'rt81854.def' => { source => "rt81854", params => "def", - expect => <<'#7...........', + expect => <<'#9...........', return "this is a descriptive error message" if $res->is_error or not length $data; -#7........... +#9........... }, 'rt87502.def' => { source => "rt87502", params => "def", - expect => <<'#8...........', + expect => <<'#10...........', if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) { # CODE } -#8........... +#10........... }, 'rt93197.def' => { source => "rt93197", params => "def", - expect => <<'#9...........', + expect => <<'#11...........', $to = $to->{$_} ||= {} for @key; if (1) { 2; } else { 3; } -#9........... +#11........... }, 'rt94338.def' => { source => "rt94338", params => "def", - expect => <<'#10...........', + expect => <<'#12...........', # for-loop in a parenthesized block-map triggered an error message map( { foreach my $item ( '0', '1' ) { print $item; } } qw(a b c) ); -#10........... +#12........... }, 'rt95419.def' => { source => "rt95419", params => "def", - expect => <<'#11...........', + expect => <<'#13...........', case "blah" => sub { { a => 1 } }; -#11........... +#13........... }, 'rt95708.def' => { source => "rt95708", params => "def", - expect => <<'#12...........', + expect => <<'#14...........', use strict; use JSON; my $ref = { @@ -310,26 +344,26 @@ my $json2 = encode_json + { when => time(), message => 'abc' }; -#12........... +#14........... }, 'rt96021.def' => { source => "rt96021", params => "def", - expect => <<'#13...........', + expect => <<'#15...........', $a->@*; $a->**; $a->$*; $a->&*; $a->%*; $a->$#* -#13........... +#15........... }, 'rt96101.def' => { source => "rt96101", params => "def", - expect => <<'#14...........', + expect => <<'#16...........', # Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine # references inside subroutine execution. @@ -350,13 +384,13 @@ sub startup { ); } -#14........... +#16........... }, 'rt98902.def' => { source => "rt98902", params => "def", - expect => <<'#15...........', + expect => <<'#17...........', my %foo = ( alpha => 1, beta => 2, @@ -366,13 +400,13 @@ my %foo = ( my @bar = map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } } ( 0 .. 32 ); -#15........... +#17........... }, 'rt98902.rt98902' => { source => "rt98902", params => "rt98902", - expect => <<'#16...........', + expect => <<'#18...........', my %foo = ( alpha => 1, beta => 2, gamma => 3, @@ -385,24 +419,24 @@ my @bar = map { padding => ( ' ' x $_ ), } } ( 0 .. 32 ); -#16........... +#18........... }, 'rt99961.def' => { source => "rt99961", params => "def", - expect => <<'#17...........', + expect => <<'#19...........', %thing = %{ print qq[blah1\n]; $b; }; -#17........... +#19........... }, 'scl.def' => { source => "scl", params => "def", - expect => <<'#18...........', + expect => <<'#20...........', # try -scl=12 to see '$returns' joined with the previous line $format = "format STDOUT =\n" @@ -411,31 +445,6 @@ my @bar = map { . &format_line('Returns: @') . '$returns' . "\n" . &format_line(' ~~ ^') . '$desc' . "\n.\n"; -#18........... - }, - - 'scl.scl' => { - source => "scl", - params => "scl", - expect => <<'#19...........', - # 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"; -#19........... - }, - - 'semicolon2.def' => { - source => "semicolon2", - params => "def", - expect => <<'#20...........', - # will not add semicolon for this block type - $highest = List::Util::reduce { - Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b - } #20........... }, }; -- 2.39.5