From: Steve Hancock Date: Wed, 13 Jun 2018 02:10:01 +0000 (-0700) Subject: added snippets for past rt issues X-Git-Tag: 20181117~28 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=958640e090e47aa215b889e798aed1d3318c011c;p=perltidy.git added snippets for past rt issues --- diff --git a/t/snippets/105484.in b/t/snippets/105484.in new file mode 100644 index 00000000..1840fba3 --- /dev/null +++ b/t/snippets/105484.in @@ -0,0 +1,3 @@ +switch (1) { + case x { 2 } else { } +} diff --git a/t/snippets/README.md b/t/snippets/README.md index 0f8f1efd..69ff612c 100644 --- a/t/snippets/README.md +++ b/t/snippets/README.md @@ -7,7 +7,7 @@ The tests are intended to give a good overall check that perltidy is working correctly at installation but they are by no means exhaustive. Thorough testing of perltidy must be done against a very large body of perl code. -Run 'make' anytime to see if recent code changes have changed the perltidy formatting. +Run 'make' after any changes or additions to see if recent code changes have changed the perltidy formatting. Folder 'tmp' contains the the most recent formatting results. Folder 'expect' contains the previous expected output of perltidy. @@ -33,6 +33,9 @@ For example, consider the source file "rt20421.in". The base name is 'rt20421'. It will be run with the default parameters. If a parameter file named "rt20421.par" exists, then it will also be run with this parameter file. +Incidentally, the numbered rt files correspond to the list at +(rt)[https://rt.cpan.org/Dist/Display.html?Status=Resolved;Queue=Perl-Tidy] + Besides these two rules, there are special naming rules for running a single script with an arbitrary number of parameter files, and a single parameter file with an arbitrary number of scripts. To describe these we need to define diff --git a/t/snippets/coverage_missing.txt b/t/snippets/coverage_missing.txt index 5f38ac60..35407170 100644 --- a/t/snippets/coverage_missing.txt +++ b/t/snippets/coverage_missing.txt @@ -1,10 +1,6 @@ # No coverage in test snippets for these parameters DEBUG backlink -blank-lines-after-opening-block -blank-lines-after-opening-block-list -blank-lines-before-closing-block -blank-lines-before-closing-block-list block-brace-vertical-tightness-list brace-left-and-indent brace-left-and-indent-list @@ -22,10 +18,6 @@ closing-side-comments-balanced closing-token-indentation cuddled-block-list cuddled-block-list-exclusive -delete-block-comments -delete-old-newlines -delete-pod -delete-side-comments dump-cuddled-block-list dump-defaults dump-long-names diff --git a/t/snippets/coverage_values.txt b/t/snippets/coverage_values.txt index 1880ce30..d2fe2fd3 100644 --- a/t/snippets/coverage_values.txt +++ b/t/snippets/coverage_values.txt @@ -1,104 +1,66 @@ $VAR1 = { - 'ignore-side-comment-lengths' => [ - 0, - 1 - ], - 'nowant-right-space' => [ - '++ --', - '..' - ], - 'outdent-long-comments' => [ - 0, - 1 - ], - 'break-at-old-comma-breakpoints' => [ - 0, - 1 - ], - 'timestamp' => [ - 0, - 1 - ], + 'outdent-long-quotes' => [ + 0, + 1 + ], + 'opening-square-bracket-right' => [ + 0, + 1 + ], 'cuddled-else' => [ 0, 1 ], - 'variable-maximum-line-length' => [ - 0, - 1 - ], - 'square-bracket-vertical-tightness-closing' => [ - 0, - 2 - ], - 'indent-spaced-block-comments' => [ - 0, - 1 - ], - 'outdent-long-quotes' => [ + 'iterations' => [ + 1 + ], + 'indent-columns' => [ + 0, + 2, + 4 + ], + 'add-semicolons' => [ + 0, + 1 + ], + 'keep-old-blank-lines' => [ + 0, + 1 + ], + 'stack-opening-paren' => [ 0, 1 ], - 'brace-vertical-tightness-closing' => [ - 0, - 2 - ], - 'want-break-after' => [ - '% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x= . << >> -> && ||' - ], - 'weld-nested-containers' => [ - 0, - 1 - ], + 'stack-opening-hash-brace' => [ + 0, + 1 + ], + 'backup-file-extension' => [ + 'bak', + '~' + ], + 'timestamp' => [ + 0, + 1 + ], 'opening-brace-on-new-line' => [ 0, 1 ], - 'closing-side-comment-interval' => [ - 20, - 6 - ], - 'minimum-space-to-comment' => [ + 'continuation-indentation' => [ + 0, 2, 4 ], - 'square-bracket-vertical-tightness' => [ - 0, - 1, - 2 - ], - 'want-right-space' => [ - '= .= =~ !~ ? :' - ], - 'closing-square-bracket-indentation' => [ - 0, - 1, - 2 - ], - 'line-up-parentheses' => [ - 0, - 1 - ], - 'perl-syntax-check-flags' => [ - '-c -T' - ], - 'add-newlines' => [ - 0, - 1 - ], - 'check-syntax' => [ - 0, - 1 - ], - 'delete-semicolons' => [ - 0, - 1 - ], - 'backup-file-extension' => [ - 'bak', - '~' - ], - 'stack-opening-square-bracket' => [ + 'closing-brace-indentation' => [ + 0, + 1, + 2 + ], + 'closing-side-comment-else-flag' => [ + 0 + ], + 'variable-maximum-line-length' => [ 0, 1 ], @@ -106,199 +68,201 @@ $VAR1 = { 0, 1 ], - 'paren-tightness' => [ - 1, - 2 - ], - 'tight-secret-operators' => [ - 0, - 1 - ], - 'character-encoding' => [ - 'none' - ], 'closing-side-comment-maximum-text' => [ 20, 40 ], - 'stack-closing-hash-brace' => [ - 0, - 1 - ], - 'comma-arrow-breakpoints' => [ - 1, - 5 - ], - 'stack-closing-square-bracket' => [ - 0, - 1 - ], - 'backup-and-modify-in-place' => [ - 0, - 1 - ], 'fuzzy-line-length' => [ 0, 1 ], - 'delete-closing-side-comments' => [ - 0, - 1 - ], - 'blank-lines-before-packages' => [ - 0, - 1 - ], - 'warning-output' => [ - 0, - 1 - ], + 'blank-lines-after-opening-block-list' => [ + '*' + ], + 'paren-vertical-tightness-closing' => [ + 0, + 2 + ], + 'closing-side-comments' => [ + 0, + 1 + ], + 'starting-indentation-level' => [ + 0 + ], + 'paren-vertical-tightness' => [ + 0, + 1, + 2 + ], + 'recombine' => [ + 0, + 1 + ], + 'maximum-fields-per-table' => [ + 0 + ], 'opening-paren-right' => [ 0, 1 ], - 'format' => [ - 'html', - 'tidy' - ], + 'delete-semicolons' => [ + 0, + 1 + ], 'closing-paren-indentation' => [ 0, 1, 2 ], - 'iterations' => [ - 1 - ], - 'default-tabsize' => [ - 8 - ], 'hanging-side-comments' => [ 0, 1 ], - 'space-for-semicolon' => [ - 0, - 1 - ], - 'add-whitespace' => [ - 0, - 1 - ], - 'stack-closing-paren' => [ - 0, - 1 - ], - 'maximum-consecutive-blank-lines' => [ - 0, - 1, - 2 - ], - 'stack-opening-paren' => [ - 0, - 1 - ], - 'blank-lines-before-subs' => [ - 0, - 1 + 'comma-arrow-breakpoints' => [ + 1, + 5 ], - 'short-concatenation-item-length' => [ - 12, - 8 - ], + 'opening-sub-brace-on-new-line' => [ + 0, + 1 + ], 'square-bracket-tightness' => [ 1, 2 ], - 'add-semicolons' => [ + 'warning-output' => [ 0, 1 ], - 'indent-columns' => [ - 0, - 2, - 4 - ], - 'opening-sub-brace-on-new-line' => [ - 0, - 1 - ], - 'paren-vertical-tightness-closing' => [ - 0, - 2 - ], - 'cuddled-break-option' => [ + 'square-bracket-vertical-tightness-closing' => [ + 0, + 2 + ], + 'blanks-before-blocks' => [ + 0, 1 ], - 'block-brace-tightness' => [ + 'delete-block-comments' => [ 0, - 1, - 2 + 1 + ], + 'add-newlines' => [ + 0, + 1 + ], + 'want-right-space' => [ + '= .= =~ !~ ? :' + ], + 'stack-closing-square-bracket' => [ + 0, + 1 + ], + 'want-break-before' => [ + ' ', + '% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=', + '% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=' + ], + 'entab-leading-whitespace' => [ + 8 + ], + 'space-backslash-quote' => [ + 1 ], + 'add-whitespace' => [ + 0, + 1 + ], + 'space-for-semicolon' => [ + 0, + 1 + ], + 'maximum-consecutive-blank-lines' => [ + 0, + 1, + 2 + ], 'standard-error-output' => [ 0, 1 ], + 'closing-side-comment-interval' => [ + 20, + 6 + ], + 'brace-tightness' => [ + 0, + 1, + 2 + ], + 'nowant-right-space' => [ + '++ --', + '..' + ], 'opening-brace-always-on-right' => [ 0, 1 ], - 'nowant-left-space' => [ - '++ -- ?', - '..' - ], + 'blank-lines-after-opening-block' => [ + 2 + ], + 'delete-closing-side-comments' => [ + 0, + 1 + ], 'delete-old-whitespace' => [ 0, 1 ], - 'closing-brace-indentation' => [ - 0, - 1, - 2 - ], - 'blanks-before-blocks' => [ - 0, - 1 - ], - 'brace-vertical-tightness' => [ - 0, - 1, - 2 - ], - 'closing-side-comment-else-flag' => [ - 0 - ], - 'stack-opening-hash-brace' => [ - 0, - 1 - ], - 'starting-indentation-level' => [ - 0 - ], - 'keep-old-blank-lines' => [ - 0, + 'cuddled-break-option' => [ 1 ], - 'brace-tightness' => [ - 0, - 1, - 2 - ], - 'maximum-fields-per-table' => [ - 0 - ], - 'space-backslash-quote' => [ - 1 + 'blank-lines-before-closing-block' => [ + 1 + ], + 'block-brace-tightness' => [ + 0, + 1, + 2 ], - 'want-left-space' => [ - '= .= =~ !~ :' - ], - 'closing-side-comments' => [ + 'outdent-long-comments' => [ 0, 1 ], - 'block-brace-vertical-tightness' => [ - 0 - ], + 'stack-closing-hash-brace' => [ + 0, + 1 + ], + 'check-syntax' => [ + 0, + 1 + ], + 'line-up-parentheses' => [ + 0, + 1 + ], + 'ignore-side-comment-lengths' => [ + 0, + 1 + ], + 'default-tabsize' => [ + 8 + ], + 'delete-old-newlines' => [ + 0, + 1 + ], + 'character-encoding' => [ + 'none' + ], + 'tight-secret-operators' => [ + 0, + 1 + ], + 'delete-pod' => [ + 0, + 1 + ], 'maximum-line-length' => [ 0, 1, @@ -309,37 +273,101 @@ $VAR1 = { 78, 80 ], - 'opening-square-bracket-right' => [ - 0, - 1 - ], - 'want-break-before' => [ - ' ', - '% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=', - '% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=' - ], + 'delete-side-comments' => [ + 0, + 1 + ], 'opening-hash-brace-right' => [ 0, 1 ], - 'paren-vertical-tightness' => [ + 'blank-lines-before-packages' => [ + 0, + 1 + ], + 'short-concatenation-item-length' => [ + 12, + 8 + ], + 'want-break-after' => [ + '% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x= . << >> -> && ||' + ], + 'brace-vertical-tightness-closing' => [ + 0, + 2 + ], + 'format' => [ + 'html', + 'tidy' + ], + 'want-left-space' => [ + '= .= =~ !~ :' + ], + 'indent-spaced-block-comments' => [ + 0, + 1 + ], + 'closing-square-bracket-indentation' => [ + 0, + 1, + 2 + ], + 'block-brace-vertical-tightness' => [ + 0 + ], + 'square-bracket-vertical-tightness' => [ + 0, + 1, + 2 + ], + 'brace-vertical-tightness' => [ 0, 1, 2 ], - 'entab-leading-whitespace' => [ - 8 + 'break-at-old-comma-breakpoints' => [ + 0, + 1 + ], + 'nowant-left-space' => [ + '++ -- ?', + '..' + ], + 'blank-lines-before-closing-block-list' => [ + '*' + ], + 'backup-and-modify-in-place' => [ + 0, + 1 + ], + 'blank-lines-before-subs' => [ + 0, + 1 + ], + 'stack-opening-square-bracket' => [ + 0, + 1 + ], + 'perl-syntax-check-flags' => [ + '-c -T' + ], + 'paren-tightness' => [ + 1, + 2 + ], + 'minimum-space-to-comment' => [ + 2, + 4 ], + 'weld-nested-containers' => [ + 0, + 1 + ], 'long-block-line-count' => [ 8 ], - 'recombine' => [ - 0, - 1 - ], - 'continuation-indentation' => [ - 0, - 2, - 4 - ] + 'stack-closing-paren' => [ + 0, + 1 + ] }; diff --git a/t/snippets/expect/105484.def b/t/snippets/expect/105484.def new file mode 100644 index 00000000..1840fba3 --- /dev/null +++ b/t/snippets/expect/105484.def @@ -0,0 +1,3 @@ +switch (1) { + case x { 2 } else { } +} diff --git a/t/snippets/expect/rt101547.def b/t/snippets/expect/rt101547.def new file mode 100644 index 00000000..8c1b0b2c --- /dev/null +++ b/t/snippets/expect/rt101547.def @@ -0,0 +1 @@ +{ source_host => MM::Config->instance->host // q{}, } diff --git a/t/snippets/expect/rt102371.def b/t/snippets/expect/rt102371.def new file mode 100644 index 00000000..8e44babb --- /dev/null +++ b/t/snippets/expect/rt102371.def @@ -0,0 +1 @@ +state $b //= ccc(); diff --git a/t/snippets/expect/rt104427.def b/t/snippets/expect/rt104427.def new file mode 100644 index 00000000..e426c399 --- /dev/null +++ b/t/snippets/expect/rt104427.def @@ -0,0 +1,7 @@ +#!/usr/bin/env perl +use v5.020; #includes strict +use warnings; +use experimental 'signatures'; +setidentifier(); +exit; +sub setidentifier ( $href = {} ) { say 'hi'; } diff --git a/t/snippets/expect/rt106492.def b/t/snippets/expect/rt106492.def new file mode 100644 index 00000000..2ef91b3f --- /dev/null +++ b/t/snippets/expect/rt106492.def @@ -0,0 +1,4 @@ +my $ct = Courriel::Header::ContentType->new( + mime_type => 'multipart/alternative', + attributes => { boundary => unique_boundary }, +); diff --git a/t/snippets/expect/rt107832.def b/t/snippets/expect/rt107832.def new file mode 100644 index 00000000..25acb75c --- /dev/null +++ b/t/snippets/expect/rt107832.def @@ -0,0 +1,7 @@ +my %temp = ( + supsup => 123, + nested => { + asdf => 456, + yarg => 'yarp', + }, +); diff --git a/t/snippets/expect/rt107832.rt107832 b/t/snippets/expect/rt107832.rt107832 new file mode 100644 index 00000000..bf81e9bf --- /dev/null +++ b/t/snippets/expect/rt107832.rt107832 @@ -0,0 +1,7 @@ +my %temp = ( + supsup => 123, + nested => { + asdf => 456, + yarg => 'yarp', + }, +); diff --git a/t/snippets/expect/rt111519.def b/t/snippets/expect/rt111519.def new file mode 100644 index 00000000..c61d2fea --- /dev/null +++ b/t/snippets/expect/rt111519.def @@ -0,0 +1,6 @@ +use strict; +use warnings; +my $x = 1; # comment not removed + +# comment will be removed +my $y = 2; # comment also not removed diff --git a/t/snippets/expect/rt111519.rt111519 b/t/snippets/expect/rt111519.rt111519 new file mode 100644 index 00000000..4c9fcc8b --- /dev/null +++ b/t/snippets/expect/rt111519.rt111519 @@ -0,0 +1,4 @@ +use strict; +use warnings; +my $x = 1; +my $y = 2; diff --git a/t/snippets/expect/rt112534.def b/t/snippets/expect/rt112534.def new file mode 100644 index 00000000..183fcea1 --- /dev/null +++ b/t/snippets/expect/rt112534.def @@ -0,0 +1,7 @@ +get( + on_ready => sub ($worker) { $on_ready->end; return; }, + on_exit => sub ( $worker, $status ) { + return; + }, + on_data => sub ($data) { $self->_on_data(@_) if $self; return; } +); diff --git a/t/snippets/expect/rt113689.def b/t/snippets/expect/rt113689.def new file mode 100644 index 00000000..666e71f4 --- /dev/null +++ b/t/snippets/expect/rt113689.def @@ -0,0 +1,6 @@ +$a = sub { + if ( !defined( $_[0] ) ) { + print("Hello, World\n"); + } + else { print( $_[0], "\n" ); } +}; diff --git a/t/snippets/expect/rt113689.rt113689 b/t/snippets/expect/rt113689.rt113689 new file mode 100644 index 00000000..4ea472a8 --- /dev/null +++ b/t/snippets/expect/rt113689.rt113689 @@ -0,0 +1,12 @@ +$a = sub { + + + if ( !defined( $_[0] ) ) { + + + print("Hello, World\n"); + + } + else { print( $_[0], "\n" ); } + +}; diff --git a/t/snippets/expect/rt113792.def b/t/snippets/expect/rt113792.def new file mode 100644 index 00000000..4148c5b3 --- /dev/null +++ b/t/snippets/expect/rt113792.def @@ -0,0 +1,3 @@ +print "hello world\n"; +__DATA__ +=> 1/2 : 0.5 diff --git a/t/snippets/expect/rt114359.def b/t/snippets/expect/rt114359.def new file mode 100644 index 00000000..449075f8 --- /dev/null +++ b/t/snippets/expect/rt114359.def @@ -0,0 +1,2 @@ +my $x = 2; +print $x **0.5; diff --git a/t/snippets/expect/rt114909.def b/t/snippets/expect/rt114909.def new file mode 100644 index 00000000..87224cd8 --- /dev/null +++ b/t/snippets/expect/rt114909.def @@ -0,0 +1,24 @@ +#!perl +use strict; +use warnings; + +use experimental 'signatures'; + +sub reader ( $line_sep, $chomp ) { + return sub ( $fh, $out ) : prototype(*$) { + local $/ = $line_sep; + my $content = <$fh>; + return undef unless defined $content; + chomp $content if $chomp; + $$out .= $content; + return 1; + }; +} + +BEGIN { + *get_line = reader( "\n", 1 ); +} + +while ( get_line( STDIN, \my $buf ) ) { + print "Got: $buf\n"; +} diff --git a/t/snippets/expect/rt119140.def b/t/snippets/expect/rt119140.def new file mode 100644 index 00000000..2a806f24 --- /dev/null +++ b/t/snippets/expect/rt119140.def @@ -0,0 +1 @@ +while ( <<>> ) { } diff --git a/t/snippets/expect/rt119588.def b/t/snippets/expect/rt119588.def new file mode 100644 index 00000000..825234e9 --- /dev/null +++ b/t/snippets/expect/rt119588.def @@ -0,0 +1,4 @@ +sub demo { + my $self = shift; + my $longname = shift // "xyz"; +} diff --git a/t/snippets/expect/rt119970.def b/t/snippets/expect/rt119970.def new file mode 100644 index 00000000..9481cd1f --- /dev/null +++ b/t/snippets/expect/rt119970.def @@ -0,0 +1,6 @@ +my $x = [ + { + fooxx => 1, + bar => 1, + } +]; diff --git a/t/snippets/expect/rt119970.rt119970 b/t/snippets/expect/rt119970.rt119970 new file mode 100644 index 00000000..fdf6dcb8 --- /dev/null +++ b/t/snippets/expect/rt119970.rt119970 @@ -0,0 +1,4 @@ +my $x = [ { + fooxx => 1, + bar => 1, +} ]; diff --git a/t/snippets/expect/rt123492.def b/t/snippets/expect/rt123492.def new file mode 100644 index 00000000..e78d936e --- /dev/null +++ b/t/snippets/expect/rt123492.def @@ -0,0 +1,5 @@ +if (1) { + print <<~EOF; + Hello there + EOF +} diff --git a/t/snippets/expect/rt123749.def b/t/snippets/expect/rt123749.def new file mode 100644 index 00000000..764dbbcf --- /dev/null +++ b/t/snippets/expect/rt123749.def @@ -0,0 +1,17 @@ +get('http://mojolicious.org')->then( + sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); + } +)->then( + sub { + my $cpan = shift; + say $cpan->res->code; + } +)->catch( + sub { + my $err = shift; + warn "Something went wrong: $err"; + } +)->wait; diff --git a/t/snippets/expect/rt123749.rt123749 b/t/snippets/expect/rt123749.rt123749 new file mode 100644 index 00000000..d63654a6 --- /dev/null +++ b/t/snippets/expect/rt123749.rt123749 @@ -0,0 +1,11 @@ +get('http://mojolicious.org')->then( sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); +} )->then( sub { + my $cpan = shift; + say $cpan->res->code; +} )->catch( sub { + my $err = shift; + warn "Something went wrong: $err"; +} )->wait; diff --git a/t/snippets/expect/rt124114.def b/t/snippets/expect/rt124114.def new file mode 100644 index 00000000..84903f69 --- /dev/null +++ b/t/snippets/expect/rt124114.def @@ -0,0 +1,7 @@ +#!/usr/bin/perl +my %h = { + a => 2 > 3 ? 1 : 0, + bbbb => sub { my $y = "1" }, + c => sub { my $z = "2" }, + d => 2 > 3 ? 1 : 0, +}; diff --git a/t/snippets/expect/rt124354.def b/t/snippets/expect/rt124354.def new file mode 100644 index 00000000..b8cf048f --- /dev/null +++ b/t/snippets/expect/rt124354.def @@ -0,0 +1,9 @@ +package Foo; + +use Moose; + +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); + +__PACKAGE__->meta->make_immutable; diff --git a/t/snippets/expect/rt124354.rt124354 b/t/snippets/expect/rt124354.rt124354 new file mode 100644 index 00000000..b8cf048f --- /dev/null +++ b/t/snippets/expect/rt124354.rt124354 @@ -0,0 +1,9 @@ +package Foo; + +use Moose; + +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); + +__PACKAGE__->meta->make_immutable; diff --git a/t/snippets/expect/rt125506.def b/t/snippets/expect/rt125506.def new file mode 100644 index 00000000..9bd8aae4 --- /dev/null +++ b/t/snippets/expect/rt125506.def @@ -0,0 +1,5 @@ +my $t = ' + un + deux + trois + '; diff --git a/t/snippets/expect/rt125506.rt125506 b/t/snippets/expect/rt125506.rt125506 new file mode 100644 index 00000000..9bd8aae4 --- /dev/null +++ b/t/snippets/expect/rt125506.rt125506 @@ -0,0 +1,5 @@ +my $t = ' + un + deux + trois + '; diff --git a/t/snippets/expect/rt15735.def b/t/snippets/expect/rt15735.def new file mode 100644 index 00000000..cd271d90 --- /dev/null +++ b/t/snippets/expect/rt15735.def @@ -0,0 +1,5 @@ +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); diff --git a/t/snippets/expect/rt27000.def b/t/snippets/expect/rt27000.def new file mode 100644 index 00000000..be3b94e9 --- /dev/null +++ b/t/snippets/expect/rt27000.def @@ -0,0 +1,9 @@ +print add( 3, 4 ), "\n"; +print add( 4, 3 ), "\n"; + +sub add { + my ( $term1, $term2 ) = @_; +# line 1234 + die "$term1 > $term2" if $term1 > $term2; + return $term1 + $term2; +} diff --git a/t/snippets/expect/rt31741.def b/t/snippets/expect/rt31741.def new file mode 100644 index 00000000..0954b991 --- /dev/null +++ b/t/snippets/expect/rt31741.def @@ -0,0 +1 @@ +$msg //= 'World'; diff --git a/t/snippets/expect/rt49289.def b/t/snippets/expect/rt49289.def new file mode 100644 index 00000000..cf2f83b9 --- /dev/null +++ b/t/snippets/expect/rt49289.def @@ -0,0 +1 @@ +use constant qw{ DEBUG 0 }; diff --git a/t/snippets/expect/rt50702.def b/t/snippets/expect/rt50702.def new file mode 100644 index 00000000..3d37e368 --- /dev/null +++ b/t/snippets/expect/rt50702.def @@ -0,0 +1,14 @@ +if (1) { + my $uid = + $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar'; +} +if (2) { + my $uid = + ( $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar' ); +} diff --git a/t/snippets/expect/rt50702.rt50702 b/t/snippets/expect/rt50702.rt50702 new file mode 100644 index 00000000..65ddbfd9 --- /dev/null +++ b/t/snippets/expect/rt50702.rt50702 @@ -0,0 +1,14 @@ +if (1) { + my $uid + = $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar'; +} +if (2) { + my $uid + = ( $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar' ); +} diff --git a/t/snippets/expect/rt68870.def b/t/snippets/expect/rt68870.def new file mode 100644 index 00000000..a3e6a1be --- /dev/null +++ b/t/snippets/expect/rt68870.def @@ -0,0 +1 @@ +s///r; diff --git a/t/snippets/expect/rt70747.def b/t/snippets/expect/rt70747.def new file mode 100644 index 00000000..8afb60d7 --- /dev/null +++ b/t/snippets/expect/rt70747.def @@ -0,0 +1,9 @@ +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ + map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; + $g; + } @$_; + ] +}; diff --git a/t/snippets/expect/rt70747.rt70747 b/t/snippets/expect/rt70747.rt70747 new file mode 100644 index 00000000..ac4fd243 --- /dev/null +++ b/t/snippets/expect/rt70747.rt70747 @@ -0,0 +1,9 @@ +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ + map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; + $g; + } @$_; + ] +}; diff --git a/t/snippets/expect/rt74856.def b/t/snippets/expect/rt74856.def new file mode 100644 index 00000000..ff793889 --- /dev/null +++ b/t/snippets/expect/rt74856.def @@ -0,0 +1,9 @@ +{ + my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> + my $baz = 'something else'; +} diff --git a/t/snippets/expect/rt78156.def b/t/snippets/expect/rt78156.def new file mode 100644 index 00000000..222af8ec --- /dev/null +++ b/t/snippets/expect/rt78156.def @@ -0,0 +1 @@ +package Some::Class 2.012; diff --git a/t/snippets/expect/rt78764.def b/t/snippets/expect/rt78764.def new file mode 100644 index 00000000..aa95895e --- /dev/null +++ b/t/snippets/expect/rt78764.def @@ -0,0 +1,2 @@ +qr/3/ ~~ ['1234'] ? 1 : 0; +map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; diff --git a/t/snippets/expect/rt79813.def b/t/snippets/expect/rt79813.def new file mode 100644 index 00000000..e466b833 --- /dev/null +++ b/t/snippets/expect/rt79813.def @@ -0,0 +1,7 @@ +my %hash = ( + a => { + bbbbbbbbb => { + cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx', + }, + }, +); diff --git a/t/snippets/expect/rt79947.def b/t/snippets/expect/rt79947.def new file mode 100644 index 00000000..8b928e90 --- /dev/null +++ b/t/snippets/expect/rt79947.def @@ -0,0 +1,4 @@ +try { croak "An Error!"; } +catch ($error) { + print STDERR $error . "\n"; +} diff --git a/t/snippets/expect/rt80645.def b/t/snippets/expect/rt80645.def new file mode 100644 index 00000000..894996f9 --- /dev/null +++ b/t/snippets/expect/rt80645.def @@ -0,0 +1,5 @@ +BEGIN { $^W = 1; } +use warnings; +use strict; +@$ = 'test'; +print $#{$}; diff --git a/t/snippets/expect/rt81852.def b/t/snippets/expect/rt81852.def new file mode 100644 index 00000000..ff1c2719 --- /dev/null +++ b/t/snippets/expect/rt81852.def @@ -0,0 +1,6 @@ +do { + { + next if ( $n % 2 ); + print $n, "\n"; + } +} while ( $n++ < 10 ); diff --git a/t/snippets/expect/rt81852.rt81852 b/t/snippets/expect/rt81852.rt81852 new file mode 100644 index 00000000..c6490f56 --- /dev/null +++ b/t/snippets/expect/rt81852.rt81852 @@ -0,0 +1,4 @@ +do {{ + next if ($n % 2); + print $n, "\n"; +}} while ($n++ < 10); diff --git a/t/snippets/expect/rt81854.def b/t/snippets/expect/rt81854.def new file mode 100644 index 00000000..3b41a537 --- /dev/null +++ b/t/snippets/expect/rt81854.def @@ -0,0 +1,2 @@ +return "this is a descriptive error message" + if $res->is_error or not length $data; diff --git a/t/snippets/expect/rt87502.def b/t/snippets/expect/rt87502.def new file mode 100644 index 00000000..b26a09ff --- /dev/null +++ b/t/snippets/expect/rt87502.def @@ -0,0 +1,4 @@ +if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) { + + # CODE +} diff --git a/t/snippets/expect/rt93197.def b/t/snippets/expect/rt93197.def new file mode 100644 index 00000000..907338ff --- /dev/null +++ b/t/snippets/expect/rt93197.def @@ -0,0 +1,3 @@ +$to = $to->{$_} ||= {} for @key; +if (1) { 2; } +else { 3; } diff --git a/t/snippets/expect/rt95419.def b/t/snippets/expect/rt95419.def new file mode 100644 index 00000000..3d5586b0 --- /dev/null +++ b/t/snippets/expect/rt95419.def @@ -0,0 +1,3 @@ +case "blah" => sub { + { a => 1 } +}; diff --git a/t/snippets/expect/rt95708.def b/t/snippets/expect/rt95708.def new file mode 100644 index 00000000..4df7f143 --- /dev/null +++ b/t/snippets/expect/rt95708.def @@ -0,0 +1,14 @@ +use strict; +use JSON; +my $ref = { + when => time(), + message => 'abc' +}; +my $json = encode_json { + when => time(), + message => 'abc' +}; +my $json2 = encode_json + { + when => time(), + message => 'abc' +}; diff --git a/t/snippets/expect/rt96021.def b/t/snippets/expect/rt96021.def new file mode 100644 index 00000000..24bb5b3d --- /dev/null +++ b/t/snippets/expect/rt96021.def @@ -0,0 +1,6 @@ +$a->@*; +$a->**; +$a->$*; +$a->&*; +$a->%*; +$a->$#* diff --git a/t/snippets/expect/rt98902.def b/t/snippets/expect/rt98902.def new file mode 100644 index 00000000..0e9bc245 --- /dev/null +++ b/t/snippets/expect/rt98902.def @@ -0,0 +1,9 @@ +my %foo = ( + alpha => 1, + beta => 2, + gamma => 3, +); + +my @bar = + map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } } + ( 0 .. 32 ); diff --git a/t/snippets/expect/rt98902.rt98902 b/t/snippets/expect/rt98902.rt98902 new file mode 100644 index 00000000..84722021 --- /dev/null +++ b/t/snippets/expect/rt98902.rt98902 @@ -0,0 +1,12 @@ +my %foo = ( + alpha => 1, + beta => 2, gamma => 3, +); + +my @bar = map { + { + number => $_, + character => chr $_, + padding => ( ' ' x $_ ), + } +} ( 0 .. 32 ); diff --git a/t/snippets/expect/rt99961.def b/t/snippets/expect/rt99961.def new file mode 100644 index 00000000..132f6f49 --- /dev/null +++ b/t/snippets/expect/rt99961.def @@ -0,0 +1,4 @@ +%thing = %{ + print qq[blah1\n]; + $b; +}; diff --git a/t/snippets/make_expect.pl b/t/snippets/make_expect.pl index 494b27b9..8e2da110 100755 --- a/t/snippets/make_expect.pl +++ b/t/snippets/make_expect.pl @@ -184,7 +184,7 @@ foreach my $basename (@olist) { my $tname = $opath . $basename; my $ename = $epath . $basename; if ( !-e $ename ) { - print "$basename is new\n"; + print "tmp/$basename is a new file\n"; push @mv, "cp $tname $ename"; } elsif ( compare( $ename, $tname ) ) { @@ -243,10 +243,14 @@ EOM close RUN; system("chmod 0755 $runme"); -my $diff_msg="Look at differences in '$diff_file'" if (-e $diff_file); + my $diff_msg = + -e $diff_file + ? "Look at differences in '$diff_file'" + : "no differences"; print <[$n]; } my $ofile = "../snippets" . $file_count . ".t"; make_snippet_t( $ofile, \@tests, $rparams, $rsources ); + print "Now run a 'make test' from the top directory to check these\n"; } sub make_snippet_t { diff --git a/t/snippets/rt101547.in b/t/snippets/rt101547.in new file mode 100644 index 00000000..8c1b0b2c --- /dev/null +++ b/t/snippets/rt101547.in @@ -0,0 +1 @@ +{ source_host => MM::Config->instance->host // q{}, } diff --git a/t/snippets/rt102371.in b/t/snippets/rt102371.in new file mode 100644 index 00000000..8e44babb --- /dev/null +++ b/t/snippets/rt102371.in @@ -0,0 +1 @@ +state $b //= ccc(); diff --git a/t/snippets/rt104427.in b/t/snippets/rt104427.in new file mode 100644 index 00000000..e426c399 --- /dev/null +++ b/t/snippets/rt104427.in @@ -0,0 +1,7 @@ +#!/usr/bin/env perl +use v5.020; #includes strict +use warnings; +use experimental 'signatures'; +setidentifier(); +exit; +sub setidentifier ( $href = {} ) { say 'hi'; } diff --git a/t/snippets/rt106492.in b/t/snippets/rt106492.in new file mode 100644 index 00000000..44baa050 --- /dev/null +++ b/t/snippets/rt106492.in @@ -0,0 +1 @@ +my $ct = Courriel::Header::ContentType->new( mime_type => 'multipart/alternative', attributes => { boundary => unique_boundary }, ); diff --git a/t/snippets/rt107832.in b/t/snippets/rt107832.in new file mode 100644 index 00000000..98061f6d --- /dev/null +++ b/t/snippets/rt107832.in @@ -0,0 +1,7 @@ +my %temp = +( +supsup => 123, +nested => { +asdf => 456, +yarg => 'yarp', +}, ); diff --git a/t/snippets/rt107832.par b/t/snippets/rt107832.par new file mode 100644 index 00000000..f71d7a59 --- /dev/null +++ b/t/snippets/rt107832.par @@ -0,0 +1,2 @@ +-lp +-boc diff --git a/t/snippets/rt111519.in b/t/snippets/rt111519.in new file mode 100644 index 00000000..13517cdc --- /dev/null +++ b/t/snippets/rt111519.in @@ -0,0 +1,5 @@ +use strict; +use warnings; +my $x = 1; # comment not removed +# comment will be removed +my $y = 2; # comment also not removed diff --git a/t/snippets/rt111519.par b/t/snippets/rt111519.par new file mode 100644 index 00000000..31918e08 --- /dev/null +++ b/t/snippets/rt111519.par @@ -0,0 +1,2 @@ +-io +-dac diff --git a/t/snippets/rt112534.in b/t/snippets/rt112534.in new file mode 100644 index 00000000..a2245583 --- /dev/null +++ b/t/snippets/rt112534.in @@ -0,0 +1 @@ +get( on_ready => sub ($worker) { $on_ready->end; return; }, on_exit => sub ( $worker, $status ) { return; }, on_data => sub ($data) { $self->_on_data(@_) if $self; return; } ); diff --git a/t/snippets/rt113689.in b/t/snippets/rt113689.in new file mode 100644 index 00000000..666e71f4 --- /dev/null +++ b/t/snippets/rt113689.in @@ -0,0 +1,6 @@ +$a = sub { + if ( !defined( $_[0] ) ) { + print("Hello, World\n"); + } + else { print( $_[0], "\n" ); } +}; diff --git a/t/snippets/rt113689.par b/t/snippets/rt113689.par new file mode 100644 index 00000000..e1f0f8c6 --- /dev/null +++ b/t/snippets/rt113689.par @@ -0,0 +1,4 @@ +-blao=2 +-blbc=1 +-blaol='*' +-blbcl='*' diff --git a/t/snippets/rt113792.in b/t/snippets/rt113792.in new file mode 100644 index 00000000..4148c5b3 --- /dev/null +++ b/t/snippets/rt113792.in @@ -0,0 +1,3 @@ +print "hello world\n"; +__DATA__ +=> 1/2 : 0.5 diff --git a/t/snippets/rt114359.in b/t/snippets/rt114359.in new file mode 100644 index 00000000..6fa3b697 --- /dev/null +++ b/t/snippets/rt114359.in @@ -0,0 +1 @@ +my $x = 2; print $x ** 0.5; diff --git a/t/snippets/rt114909.in b/t/snippets/rt114909.in new file mode 100644 index 00000000..87224cd8 --- /dev/null +++ b/t/snippets/rt114909.in @@ -0,0 +1,24 @@ +#!perl +use strict; +use warnings; + +use experimental 'signatures'; + +sub reader ( $line_sep, $chomp ) { + return sub ( $fh, $out ) : prototype(*$) { + local $/ = $line_sep; + my $content = <$fh>; + return undef unless defined $content; + chomp $content if $chomp; + $$out .= $content; + return 1; + }; +} + +BEGIN { + *get_line = reader( "\n", 1 ); +} + +while ( get_line( STDIN, \my $buf ) ) { + print "Got: $buf\n"; +} diff --git a/t/snippets/rt119140.in b/t/snippets/rt119140.in new file mode 100644 index 00000000..f42192dd --- /dev/null +++ b/t/snippets/rt119140.in @@ -0,0 +1 @@ +while (<<>>) { } diff --git a/t/snippets/rt119588.in b/t/snippets/rt119588.in new file mode 100644 index 00000000..825234e9 --- /dev/null +++ b/t/snippets/rt119588.in @@ -0,0 +1,4 @@ +sub demo { + my $self = shift; + my $longname = shift // "xyz"; +} diff --git a/t/snippets/rt119970.in b/t/snippets/rt119970.in new file mode 100644 index 00000000..adcc60d9 --- /dev/null +++ b/t/snippets/rt119970.in @@ -0,0 +1,6 @@ +my $x = [ + { + fooxx => 1, + bar => 1, + } +]; diff --git a/t/snippets/rt119970.par b/t/snippets/rt119970.par new file mode 100644 index 00000000..817f1819 --- /dev/null +++ b/t/snippets/rt119970.par @@ -0,0 +1 @@ +-wn diff --git a/t/snippets/rt123492.in b/t/snippets/rt123492.in new file mode 100644 index 00000000..e78d936e --- /dev/null +++ b/t/snippets/rt123492.in @@ -0,0 +1,5 @@ +if (1) { + print <<~EOF; + Hello there + EOF +} diff --git a/t/snippets/rt123749.in b/t/snippets/rt123749.in new file mode 100644 index 00000000..764dbbcf --- /dev/null +++ b/t/snippets/rt123749.in @@ -0,0 +1,17 @@ +get('http://mojolicious.org')->then( + sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); + } +)->then( + sub { + my $cpan = shift; + say $cpan->res->code; + } +)->catch( + sub { + my $err = shift; + warn "Something went wrong: $err"; + } +)->wait; diff --git a/t/snippets/rt123749.par b/t/snippets/rt123749.par new file mode 100644 index 00000000..817f1819 --- /dev/null +++ b/t/snippets/rt123749.par @@ -0,0 +1 @@ +-wn diff --git a/t/snippets/rt124114.in b/t/snippets/rt124114.in new file mode 100644 index 00000000..84903f69 --- /dev/null +++ b/t/snippets/rt124114.in @@ -0,0 +1,7 @@ +#!/usr/bin/perl +my %h = { + a => 2 > 3 ? 1 : 0, + bbbb => sub { my $y = "1" }, + c => sub { my $z = "2" }, + d => 2 > 3 ? 1 : 0, +}; diff --git a/t/snippets/rt124354.in b/t/snippets/rt124354.in new file mode 100644 index 00000000..b8cf048f --- /dev/null +++ b/t/snippets/rt124354.in @@ -0,0 +1,9 @@ +package Foo; + +use Moose; + +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); + +__PACKAGE__->meta->make_immutable; diff --git a/t/snippets/rt124354.par b/t/snippets/rt124354.par new file mode 100644 index 00000000..3bee571b --- /dev/null +++ b/t/snippets/rt124354.par @@ -0,0 +1 @@ +-io diff --git a/t/snippets/rt125506.in b/t/snippets/rt125506.in new file mode 100644 index 00000000..9bd8aae4 --- /dev/null +++ b/t/snippets/rt125506.in @@ -0,0 +1,5 @@ +my $t = ' + un + deux + trois + '; diff --git a/t/snippets/rt125506.par b/t/snippets/rt125506.par new file mode 100644 index 00000000..3bee571b --- /dev/null +++ b/t/snippets/rt125506.par @@ -0,0 +1 @@ +-io diff --git a/t/snippets/rt15735.in b/t/snippets/rt15735.in new file mode 100644 index 00000000..0444a871 --- /dev/null +++ b/t/snippets/rt15735.in @@ -0,0 +1 @@ +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 ); diff --git a/t/snippets/rt27000.in b/t/snippets/rt27000.in new file mode 100644 index 00000000..be3b94e9 --- /dev/null +++ b/t/snippets/rt27000.in @@ -0,0 +1,9 @@ +print add( 3, 4 ), "\n"; +print add( 4, 3 ), "\n"; + +sub add { + my ( $term1, $term2 ) = @_; +# line 1234 + die "$term1 > $term2" if $term1 > $term2; + return $term1 + $term2; +} diff --git a/t/snippets/rt31741.in b/t/snippets/rt31741.in new file mode 100644 index 00000000..0954b991 --- /dev/null +++ b/t/snippets/rt31741.in @@ -0,0 +1 @@ +$msg //= 'World'; diff --git a/t/snippets/rt49289.in b/t/snippets/rt49289.in new file mode 100644 index 00000000..cf2f83b9 --- /dev/null +++ b/t/snippets/rt49289.in @@ -0,0 +1 @@ +use constant qw{ DEBUG 0 }; diff --git a/t/snippets/rt50702.in b/t/snippets/rt50702.in new file mode 100644 index 00000000..3b94fad7 --- /dev/null +++ b/t/snippets/rt50702.in @@ -0,0 +1 @@ +if (1) { my $uid = $ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'; } if (2) { my $uid = ($ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'); } diff --git a/t/snippets/rt50702.par b/t/snippets/rt50702.par new file mode 100644 index 00000000..81622dfd --- /dev/null +++ b/t/snippets/rt50702.par @@ -0,0 +1 @@ +-wbb='=' diff --git a/t/snippets/rt68870.in b/t/snippets/rt68870.in new file mode 100644 index 00000000..a3e6a1be --- /dev/null +++ b/t/snippets/rt68870.in @@ -0,0 +1 @@ +s///r; diff --git a/t/snippets/rt70747.in b/t/snippets/rt70747.in new file mode 100644 index 00000000..e09e35ef --- /dev/null +++ b/t/snippets/rt70747.in @@ -0,0 +1,7 @@ +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g; + } @$_; + ] +}; diff --git a/t/snippets/rt70747.par b/t/snippets/rt70747.par new file mode 100644 index 00000000..0069de82 --- /dev/null +++ b/t/snippets/rt70747.par @@ -0,0 +1 @@ +-i=2 diff --git a/t/snippets/rt74856.in b/t/snippets/rt74856.in new file mode 100644 index 00000000..8b09c055 --- /dev/null +++ b/t/snippets/rt74856.in @@ -0,0 +1,9 @@ +{ +my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> +my $baz = 'something else'; +} diff --git a/t/snippets/rt78156.in b/t/snippets/rt78156.in new file mode 100644 index 00000000..222af8ec --- /dev/null +++ b/t/snippets/rt78156.in @@ -0,0 +1 @@ +package Some::Class 2.012; diff --git a/t/snippets/rt78764.in b/t/snippets/rt78764.in new file mode 100644 index 00000000..aa95895e --- /dev/null +++ b/t/snippets/rt78764.in @@ -0,0 +1,2 @@ +qr/3/ ~~ ['1234'] ? 1 : 0; +map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; diff --git a/t/snippets/rt79813.in b/t/snippets/rt79813.in new file mode 100644 index 00000000..26eec544 --- /dev/null +++ b/t/snippets/rt79813.in @@ -0,0 +1,3 @@ +my %hash = ( a => { bbbbbbbbb => { + cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx', + }, },); diff --git a/t/snippets/rt79947.in b/t/snippets/rt79947.in new file mode 100644 index 00000000..8b928e90 --- /dev/null +++ b/t/snippets/rt79947.in @@ -0,0 +1,4 @@ +try { croak "An Error!"; } +catch ($error) { + print STDERR $error . "\n"; +} diff --git a/t/snippets/rt80645.in b/t/snippets/rt80645.in new file mode 100644 index 00000000..894996f9 --- /dev/null +++ b/t/snippets/rt80645.in @@ -0,0 +1,5 @@ +BEGIN { $^W = 1; } +use warnings; +use strict; +@$ = 'test'; +print $#{$}; diff --git a/t/snippets/rt81852.in b/t/snippets/rt81852.in new file mode 100644 index 00000000..ff1c2719 --- /dev/null +++ b/t/snippets/rt81852.in @@ -0,0 +1,6 @@ +do { + { + next if ( $n % 2 ); + print $n, "\n"; + } +} while ( $n++ < 10 ); diff --git a/t/snippets/rt81852.par b/t/snippets/rt81852.par new file mode 100644 index 00000000..9d2a44d2 --- /dev/null +++ b/t/snippets/rt81852.par @@ -0,0 +1,2 @@ +-wn +-act=2 diff --git a/t/snippets/rt81854.in b/t/snippets/rt81854.in new file mode 100644 index 00000000..3b41a537 --- /dev/null +++ b/t/snippets/rt81854.in @@ -0,0 +1,2 @@ +return "this is a descriptive error message" + if $res->is_error or not length $data; diff --git a/t/snippets/rt87502.in b/t/snippets/rt87502.in new file mode 100644 index 00000000..c1e9c28f --- /dev/null +++ b/t/snippets/rt87502.in @@ -0,0 +1,3 @@ +if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) { + # CODE +} diff --git a/t/snippets/rt93197.in b/t/snippets/rt93197.in new file mode 100644 index 00000000..f428b9f7 --- /dev/null +++ b/t/snippets/rt93197.in @@ -0,0 +1 @@ +$to = $to->{$_} ||= {} for @key; if (1) {2;} else {3;} diff --git a/t/snippets/rt95419.in b/t/snippets/rt95419.in new file mode 100644 index 00000000..3d5586b0 --- /dev/null +++ b/t/snippets/rt95419.in @@ -0,0 +1,3 @@ +case "blah" => sub { + { a => 1 } +}; diff --git a/t/snippets/rt95708.in b/t/snippets/rt95708.in new file mode 100644 index 00000000..f686b8f9 --- /dev/null +++ b/t/snippets/rt95708.in @@ -0,0 +1,8 @@ +use strict; +use JSON; +my $ref = { +when => time(), message => 'abc' }; +my $json = encode_json { +when => time(), message => 'abc' }; +my $json2 = encode_json + { +when => time(), message => 'abc' }; diff --git a/t/snippets/rt96021.in b/t/snippets/rt96021.in new file mode 100644 index 00000000..24bb5b3d --- /dev/null +++ b/t/snippets/rt96021.in @@ -0,0 +1,6 @@ +$a->@*; +$a->**; +$a->$*; +$a->&*; +$a->%*; +$a->$#* diff --git a/t/snippets/rt98902.in b/t/snippets/rt98902.in new file mode 100644 index 00000000..56250cba --- /dev/null +++ b/t/snippets/rt98902.in @@ -0,0 +1,10 @@ +my %foo = ( + alpha => 1, +beta => 2, gamma => 3, +); + +my @bar = map { { +number => $_, +character => chr $_, +padding => ( ' ' x $_ ), +} } ( 0 .. 32 ); diff --git a/t/snippets/rt98902.par b/t/snippets/rt98902.par new file mode 100644 index 00000000..081a3bdf --- /dev/null +++ b/t/snippets/rt98902.par @@ -0,0 +1 @@ +-boc diff --git a/t/snippets/rt99961.in b/t/snippets/rt99961.in new file mode 100644 index 00000000..198f1908 --- /dev/null +++ b/t/snippets/rt99961.in @@ -0,0 +1 @@ +%thing = %{ print qq[blah1\n]; $b; }; diff --git a/t/snippets1.t b/t/snippets1.t index e0cf8c69..b2837b90 100644 --- a/t/snippets1.t +++ b/t/snippets1.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:22 2018 +# Tue Jun 12 19:09:23 2018 # To locate test #13 for example, search for the string '#13' @@ -24,6 +24,12 @@ BEGIN { ###################### $rsources = { + '105484' => <<'----------', +switch (1) { + case x { 2 } else { } +} +---------- + 'align1' => <<'----------', return ( $fetch_key eq $fk && $store_key eq $sk @@ -193,17 +199,6 @@ if ( ( ( $old_new and $old_new eq 'changed' ) { return "update"; } ----------- - - 'angle' => <<'----------', -# This is an angle operator: -@message_list =sort sort_algorithm < INDEX_FILE >;# angle operator - -# Not an angle operator: -# Patched added in guess routine for this case: -if ( VERSION < 5.009 && $op->name eq 'aassign' ) { -} - ---------- }; @@ -212,35 +207,45 @@ if ( VERSION < 5.009 && $op->name eq 'aassign' ) { ############################## $rtests = { + '105484.def' => { + source => "105484", + params => "def", + expect => <<'#1...........', +switch (1) { + case x { 2 } else { } +} +#1........... + }, + 'align1.def' => { source => "align1", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', return ( $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ); -#1........... +#2........... }, 'align2.def' => { source => "align2", params => "def", - expect => <<'#2...........', + expect => <<'#3...........', same = ( ( $aP eq $bP ) && ( $aS eq $bS ) && ( $aT eq $bT ) && ( $a->{'title'} eq $b->{'title'} ) && ( $a->{'href'} eq $b->{'href'} ) ); -#2........... +#3........... }, 'align3.def' => { source => "align3", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', # This greatly improved after dropping 'ne' and 'eq': if ( $dir eq $updir and # if we have an updir @@ -252,36 +257,36 @@ if ( { $bla; } -#3........... +#4........... }, 'align4.def' => { source => "align4", params => "def", - expect => <<'#4...........', + expect => <<'#5...........', # removed 'eq' and '=~' from alignment tokens to get alignment of '?'s my $salute = $name eq $EMPTY_STR ? 'Customer' : $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1 : $name =~ m/(.*), \s+ Ph[.]?D \z /xms ? "Dr $1" : $name; -#4........... +#5........... }, 'align5.def' => { source => "align5", params => "def", - expect => <<'#5...........', + expect => <<'#6...........', printline( "Broadcast", &bintodq($b), ( $b, $mask, $bcolor, 0 ) ); printline( "HostMin", &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) ); printline( "HostMax", &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) ); -#5........... +#6........... }, 'align6.def' => { source => "align6", params => "def", - expect => <<'#6...........', + expect => <<'#7...........', # align opening parens if ( ( index( $msg_line_lc, $nick1 ) != -1 ) || ( index( $msg_line_lc, $nick2 ) != -1 ) @@ -289,36 +294,36 @@ if ( ( index( $msg_line_lc, $nick1 ) != -1 ) { do_something(); } -#6........... +#7........... }, 'align7.def' => { source => "align7", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', # Alignment with two fat commas in second line my $ct = Courriel::Header::ContentType->new( mime_type => 'multipart/alternative', attributes => { boundary => unique_boundary }, ); -#7........... +#8........... }, 'align8.def' => { source => "align8", params => "def", - expect => <<'#8...........', + expect => <<'#9...........', # aligning '=' and padding 'if' if ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value } elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"} = $value } elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"} = $value } -#8........... +#9........... }, 'align9.def' => { source => "align9", params => "def", - expect => <<'#9...........', + expect => <<'#10...........', # test of aligning || my $os = ( $ExtUtils::MM_Unix::Is_OS2 || 0 ) + @@ -326,23 +331,23 @@ my $os = ( $ExtUtils::MM_Unix::Is_Win32 || 0 ) + ( $ExtUtils::MM_Unix::Is_Dos || 0 ) + ( $ExtUtils::MM_Unix::Is_VMS || 0 ); -#9........... +#10........... }, 'andor1.def' => { source => "andor1", params => "def", - expect => <<'#10...........', + expect => <<'#11...........', return 1 if $det_a < 0 and $det_b > 0 or $det_a > 0 and $det_b < 0; -#10........... +#11........... }, 'andor10.def' => { source => "andor10", params => "def", - expect => <<'#11...........', + expect => <<'#12...........', if ( ( ($a) @@ -357,33 +362,33 @@ if ( { $i++; } -#11........... +#12........... }, 'andor2.def' => { source => "andor2", params => "def", - expect => <<'#12...........', + expect => <<'#13...........', # breaks at = or at && but not both my $success = ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0; -#12........... +#13........... }, 'andor3.def' => { source => "andor3", params => "def", - expect => <<'#13...........', + expect => <<'#14...........', ok( ( $obj->name() eq $obj2->name() ) and ( $obj->version() eq $obj2->version() ) and ( $obj->help() eq $obj2->help() ) ); -#13........... +#14........... }, 'andor4.def' => { source => "andor4", params => "def", - expect => <<'#14...........', + expect => <<'#15...........', if ( !$verbose_error && ( @@ -394,13 +399,13 @@ ok( ( $obj->name() eq $obj2->name() ) || ( $options->{'verbose'} & 64 ) ) ) ) -#14........... +#15........... }, 'andor5.def' => { source => "andor5", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # two levels of && with side comments if ( defined &syscopy @@ -412,13 +417,13 @@ ok( ( $obj->name() eq $obj2->name() ) { return syscopy( $from, $to ); } -#15........... +#16........... }, 'andor6.def' => { source => "andor6", params => "def", - expect => <<'#16...........', + expect => <<'#17...........', # Example of nested ands and ors sub is_miniwhile { # check for one-line loop (`foo() while $y--') my $op = shift; @@ -437,33 +442,33 @@ sub is_miniwhile { # check for one-line loop (`foo() while $y--') ) ); } -#16........... +#17........... }, 'andor7.def' => { source => "andor7", params => "def", - expect => <<'#17...........', + expect => <<'#18...........', # original is single line: $a = 1 if $l and !$r or !$l and $r; -#17........... +#18........... }, 'andor8.def' => { source => "andor8", params => "def", - expect => <<'#18...........', + expect => <<'#19...........', # original is broken: $a = 1 if $l and !$r or !$l and $r; -#18........... +#19........... }, 'andor9.def' => { source => "andor9", params => "def", - expect => <<'#19...........', + expect => <<'#20...........', if ( ( ( $old_new and $old_new eq 'changed' ) @@ -480,21 +485,6 @@ if ( { return "update"; } -#19........... - }, - - 'angle.def' => { - source => "angle", - params => "def", - expect => <<'#20...........', -# This is an angle operator: -@message_list = sort sort_algorithm < INDEX_FILE >; # angle operator - -# Not an angle operator: -# Patched added in guess routine for this case: -if ( VERSION < 5.009 && $op->name eq 'aassign' ) { -} - #20........... }, }; diff --git a/t/snippets10.t b/t/snippets10.t index 8cb820f4..610b287e 100644 --- a/t/snippets10.t +++ b/t/snippets10.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:24 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -18,8 +18,97 @@ BEGIN { # SECTION 1: Parameter combinations # ##################################### $rparams = { - 'def' => "", - 'wn' => "-wn", + 'def' => "", + '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 +---------- }; ###################### @@ -27,44 +116,277 @@ BEGIN { ###################### $rsources = { - 'wn5' => <<'----------', -# qw weld with -wn -use_all_ok( - qw{ - PPI - PPI::Tokenizer - PPI::Lexer - PPI::Dumper - PPI::Find - PPI::Normal - PPI::Util - PPI::Cache - } -); ----------- - - 'wn6' => <<'----------', - # illustration of some do-not-weld rules - - # do not weld a two-line function call - $trans->add_transformation( PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); - - # but weld this more complex statement - my $compass = uc( opposite_direction( line_to_canvas_direction( - @{ $coords[0] }, @{ $coords[1] } ) ) ); - - # do not weld to a one-line block because the function could get separated - # from its opening paren - $_[0]->code_handler - ( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); - - # another example; do not weld because the sub is not broken - $wrapped->add_around_modifier( - sub { push @tracelog => 'around 1'; $_[0]->(); } ); - - # but okay to weld here because the sub is broken - $wrapped->add_around_modifier( sub { - push @tracelog => 'around 1'; $_[0]->(); } ); + '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 + } + } +} + +---------- + + 'sub1' => <<'----------', +my::doit(); +join::doit(); +for::doit(); +sub::doit(); +package::doit(); +__END__::doit(); +__DATA__::doit(); +package my; +sub doit{print"Hello My\n";}package join; +sub doit{print"Hello Join\n";}package for; +sub doit{print"Hello for\n";}package package; +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' } } + } ---------- }; @@ -73,113 +395,646 @@ use_all_ok( ############################## $rtests = { - 'wn5.def' => { - source => "wn5", + 'side_comments1.def' => { + source => "side_comments1", params => "def", expect => <<'#1...........', -# qw weld with -wn -use_all_ok( - qw{ - PPI - PPI::Tokenizer - PPI::Lexer - PPI::Dumper - PPI::Find - PPI::Normal - PPI::Util - PPI::Cache - } -); + # 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 #1........... }, - 'wn5.wn' => { - source => "wn5", - params => "wn", + 'sil1.def' => { + source => "sil1", + params => "def", expect => <<'#2...........', -# qw weld with -wn -use_all_ok( qw{ - PPI - PPI::Tokenizer - PPI::Lexer - PPI::Dumper - PPI::Find - PPI::Normal - PPI::Util - PPI::Cache - } ); +############################################################# + # 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; + #2........... }, - 'wn6.def' => { - source => "wn6", - params => "def", + 'sil1.sil' => { + source => "sil1", + params => "sil", expect => <<'#3...........', - # illustration of some do-not-weld rules - - # do not weld a two-line function call - $trans->add_transformation( - PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); - - # but weld this more complex statement - my $compass = uc( - opposite_direction( - line_to_canvas_direction( - @{ $coords[0] }, @{ $coords[1] } - ) - ) - ); - - # do not weld to a one-line block because the function could get separated - # from its opening paren - $_[0]->code_handler( - sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); - - # another example; do not weld because the sub is not broken - $wrapped->add_around_modifier( - sub { push @tracelog => 'around 1'; $_[0]->(); } ); - - # but okay to weld here because the sub is broken - $wrapped->add_around_modifier( - sub { - push @tracelog => 'around 1'; - $_[0]->(); - } - ); +############################################################# +# 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; + #3........... }, - 'wn6.wn' => { - source => "wn6", - params => "wn", + 'slashslash.def' => { + source => "slashslash", + params => "def", expect => <<'#4...........', - # illustration of some do-not-weld rules - - # do not weld a two-line function call - $trans->add_transformation( - PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); - - # but weld this more complex statement - my $compass = uc( opposite_direction( line_to_canvas_direction( - @{ $coords[0] }, @{ $coords[1] } - ) ) ); - - # do not weld to a one-line block because the function could get separated - # from its opening paren - $_[0]->code_handler( - sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); - - # another example; do not weld because the sub is not broken - $wrapped->add_around_modifier( - sub { push @tracelog => 'around 1'; $_[0]->(); } ); - - # but okay to weld here because the sub is broken - $wrapped->add_around_modifier( sub { - push @tracelog => 'around 1'; - $_[0]->(); - } ); +$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' =~ //; #4........... }, + + 'smart.def' => { + source => "smart", + params => "def", + expect => <<'#5...........', +\&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; +#5........... + }, + + 'space1.def' => { + source => "space1", + params => "def", + expect => <<'#6...........', + # 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] } ); +#6........... + }, + + 'space2.def' => { + source => "space2", + params => "def", + expect => <<'#7...........', +# space before this opening paren +for $i ( 0 .. 20 ) { } + +# retain any space between '-' and bare word +$myhash{ USER-NAME } = 'steve'; +#7........... + }, + + 'space3.def' => { + source => "space3", + params => "def", + expect => <<'#8...........', +# Treat newline as a whitespace. Otherwise, we might combine +# 'Send' and '-recipients' here +my $msg = new Fax::Send + -recipients => $to, + -data => $data; +#8........... + }, + + 'space4.def' => { + source => "space4", + params => "def", + expect => <<'#9...........', +# 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........... + }, + + 'space5.def' => { + source => "space5", + params => "def", + expect => <<'#10...........', +# 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........... + }, + + 'structure1.def' => { + source => "structure1", + params => "def", + expect => <<'#11...........', +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?" + ) + ) + ) + ); +#11........... + }, + + 'style.def' => { + source => "style", + params => "def", + expect => <<'#12...........', +# 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 + } + } +} + +#12........... + }, + + 'style.style1' => { + source => "style", + params => "style1", + expect => <<'#13...........', +# 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 + } + } +} + +#13........... + }, + + 'style.style2' => { + source => "style", + params => "style2", + expect => <<'#14...........', +# 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 + } + } +} + +#14........... + }, + + 'style.style3' => { + source => "style", + params => "style3", + 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 + } + } +} ## end sub arrange_topframe + +#15........... + }, + + 'style.style4' => { + source => "style", + params => "style4", + 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.style5' => { + source => "style", + params => "style5", + 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........... + }, + + 'sub1.def' => { + source => "sub1", + params => "def", + expect => <<'#18...........', +my::doit(); +join::doit(); +for::doit(); +sub::doit(); +package::doit(); +__END__::doit(); +__DATA__::doit(); + +package my; +sub doit { print "Hello My\n"; } + +package join; +sub doit { print "Hello Join\n"; } + +package for; +sub doit { print "Hello for\n"; } + +package package; +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"; } +#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........... + }, }; my $ntests = 0 + keys %{$rtests}; diff --git a/t/snippets11.t b/t/snippets11.t new file mode 100644 index 00000000..1bed45ad --- /dev/null +++ b/t/snippets11.t @@ -0,0 +1,533 @@ +# **This script was automatically generated** +# Created with: ./make_t.pl +# Tue Jun 12 19:09:24 2018 + +# To locate test #13 for example, search for the string '#13' + +use strict; +use Test; +use Carp; +use Perl::Tidy; +my $rparams; +my $rsources; +my $rtests; + +BEGIN { + + ##################################### + # SECTION 1: Parameter combinations # + ##################################### + $rparams = { + 'def' => "", + 'tso' => "-tso", + 'vmll' => <<'----------', +-vmll +-bbt=2 +-bt=2 +-pt=2 +-sbt=2 +---------- + 'vtc' => <<'----------', +-sbvtc=2 +-bvtc=2 +-pvtc=2 +---------- + }; + + ###################### + # SECTION 2: Sources # + ###################### + $rsources = { + + 'syntax1' => <<'----------', +# Caused trouble: +print $x **2; +---------- + + 'syntax2' => <<'----------', +# ? was taken as pattern +my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; +---------- + + 'ternary1' => <<'----------', +my $flags = + ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE : + ( $_ & 4 ) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; +---------- + + 'ternary2' => <<'----------', +my $a=($b) ? ($c) ? ($d) ? $d1 + : $d2 + : ($e) ? $e1 + : $e2 + : ($f) ? ($g) ? $g1 + : $g2 + : ($h) ? $h1 + : $h2; +---------- + + 'tick1' => <<'----------', +sub a'this { $p'u'a = "mooo\n"; print $p::u::a; } +a::this(); # print "mooo" +print $p'u'a; # print "mooo" +sub a::that { + $p't'u = "wwoo\n"; + return sub { print $p't'u} +} +$a'that = a'that(); +$a'that->(); # print "wwoo" +$a'that = a'that(); +$p::t::u = "booo\n"; +$a'that->(); # print "booo" +---------- + + 'trim_quote' => <<'----------', +# space after quote will get trimmed + push @m, ' +all :: pure_all manifypods + ' . $self->{NOECHO} . '$(NOOP) +' + unless $self->{SKIPHASH}{'all'}; +---------- + + 'tso1' => <<'----------', +print 0+ '42 EUR'; # 42 +---------- + + 'tutor' => <<'----------', +#!/usr/bin/perl +$y=shift||5;for $i(1..10){$l[$i]="T";$w[$i]=999999;}while(1){print"Name:";$u=;$t=50;$a=time;for(0..9){$x="";for(1..$y){$x.=chr(int(rand(126-33)+33));}while($z ne $x){print"\r\n$x\r\n";$z=;chomp($z);$t-=5;}}$b=time;$t-=($b-$a)*2;$t=0-$t;$z=1;@q=@l;@p=@w;print "You scored $t points\r\nTopTen\r\n";for $i(1..10){if ($t<$p[$z]){$l[$i]=$u;chomp($l[$i]);$w[$i]=$t;$t=1000000}else{$l[$i]=$q[$z];$w[$i]=$p[$z];$z++;}print $l[$i],"\t",$w[$i],"\r\n";}} +---------- + + 'undoci1' => <<'----------', + $rinfo{deleteStyle} = [ + -fill => 'red', + -stipple => '@' . Tk->findINC('demos/images/grey.25'), + ]; +---------- + + 'use1' => <<'----------', +# previously this caused an incorrect error message after '2.42' +use lib "$Common::global::gInstallRoot/lib"; +use CGI 2.42 qw(fatalsToBrowser); +use RRDs 1.000101; + +# the 0666 must expect an operator +use constant MODE => do { 0666 & ( 0777 & ~umask ) }; + +use IO::File (); +---------- + + 'use2' => <<'----------', +# 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); +---------- + + 'version1' => <<'----------', +# VERSION statement unbroken, no semicolon added; +our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r } +---------- + + 'version2' => <<'----------', +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; +---------- + + 'vert' => <<'----------', +# if $w->vert is tokenized as type 'U' then the ? will start a quote +# and an error will occur. +sub vert { +} +sub Restore { + $w->vert ? $w->delta_width(0) : $w->delta_height(0); +} +---------- + + 'vmll' => <<'----------', + # 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))} + + This has the comma on the next line + exception {Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)}, +---------- + + '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( + SOAP::Data->name('getStateName') + ->attr( { xmlns => 'urn:/My/Examples' } ), + 1 + )->result eq 'Alabama' + ); +---------- + }; + + ############################## + # SECTION 3: Expected output # + ############################## + $rtests = { + + 'syntax1.def' => { + source => "syntax1", + params => "def", + expect => <<'#1...........', +# Caused trouble: +print $x **2; +#1........... + }, + + 'syntax2.def' => { + source => "syntax2", + params => "def", + expect => <<'#2...........', +# ? was taken as pattern +my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; +#2........... + }, + + 'ternary1.def' => { + source => "ternary1", + params => "def", + expect => <<'#3...........', +my $flags = + ( $_ & 1 ) + ? ( $_ & 4 ) + ? $THRf_DEAD + : $THRf_ZOMBIE + : ( $_ & 4 ) ? $THRf_R_DETACHED + : $THRf_R_JOINABLE; +#3........... + }, + + 'ternary2.def' => { + source => "ternary2", + params => "def", + expect => <<'#4...........', +my $a = + ($b) + ? ($c) + ? ($d) + ? $d1 + : $d2 + : ($e) ? $e1 + : $e2 + : ($f) ? ($g) + ? $g1 + : $g2 + : ($h) ? $h1 + : $h2; +#4........... + }, + + 'tick1.def' => { + source => "tick1", + params => "def", + expect => <<'#5...........', +sub a'this { $p'u'a = "mooo\n"; print $p::u::a; } +a::this(); # print "mooo" +print $p'u'a; # print "mooo" + +sub a::that { + $p't'u = "wwoo\n"; + return sub { print $p't'u} +} +$a'that = a'that(); +$a'that->(); # print "wwoo" +$a'that = a'that(); +$p::t::u = "booo\n"; +$a'that->(); # print "booo" +#5........... + }, + + 'trim_quote.def' => { + source => "trim_quote", + params => "def", + expect => <<'#6...........', + # space after quote will get trimmed + push @m, ' +all :: pure_all manifypods + ' . $self->{NOECHO} . '$(NOOP) +' + unless $self->{SKIPHASH}{'all'}; +#6........... + }, + + 'tso1.def' => { + source => "tso1", + params => "def", + expect => <<'#7...........', +print 0 + '42 EUR'; # 42 +#7........... + }, + + 'tso1.tso' => { + source => "tso1", + params => "tso", + expect => <<'#8...........', +print 0+ '42 EUR'; # 42 +#8........... + }, + + 'tutor.def' => { + source => "tutor", + params => "def", + expect => <<'#9...........', +#!/usr/bin/perl +$y = shift || 5; +for $i ( 1 .. 10 ) { $l[$i] = "T"; $w[$i] = 999999; } +while (1) { + print "Name:"; + $u = ; + $t = 50; + $a = time; + for ( 0 .. 9 ) { + $x = ""; + for ( 1 .. $y ) { $x .= chr( int( rand( 126 - 33 ) + 33 ) ); } + while ( $z ne $x ) { + print "\r\n$x\r\n"; + $z = ; + chomp($z); + $t -= 5; + } + } + $b = time; + $t -= ( $b - $a ) * 2; + $t = 0 - $t; + $z = 1; + @q = @l; + @p = @w; + print "You scored $t points\r\nTopTen\r\n"; + + for $i ( 1 .. 10 ) { + if ( $t < $p[$z] ) { + $l[$i] = $u; + chomp( $l[$i] ); + $w[$i] = $t; + $t = 1000000; + } + else { $l[$i] = $q[$z]; $w[$i] = $p[$z]; $z++; } + print $l[$i], "\t", $w[$i], "\r\n"; + } +} +#9........... + }, + + 'undoci1.def' => { + source => "undoci1", + params => "def", + expect => <<'#10...........', + $rinfo{deleteStyle} = [ + -fill => 'red', + -stipple => '@' . Tk->findINC('demos/images/grey.25'), + ]; +#10........... + }, + + 'use1.def' => { + source => "use1", + params => "def", + expect => <<'#11...........', +# previously this caused an incorrect error message after '2.42' +use lib "$Common::global::gInstallRoot/lib"; +use CGI 2.42 qw(fatalsToBrowser); +use RRDs 1.000101; + +# the 0666 must expect an operator +use constant MODE => do { 0666 & ( 0777 & ~umask ) }; + +use IO::File (); +#11........... + }, + + 'use2.def' => { + source => "use2", + params => "def", + expect => <<'#12...........', +# 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........... + }, + + 'version1.def' => { + source => "version1", + params => "def", + expect => <<'#13...........', +# VERSION statement unbroken, no semicolon added; +our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r } +#13........... + }, + + 'version2.def' => { + source => "version2", + params => "def", + expect => <<'#14...........', +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; +#14........... + }, + + 'vert.def' => { + source => "vert", + params => "def", + expect => <<'#15...........', +# if $w->vert is tokenized as type 'U' then the ? will start a quote +# and an error will occur. +sub vert { +} + +sub Restore { + $w->vert ? $w->delta_width(0) : $w->delta_height(0); +} +#15........... + }, + + 'vmll.def' => { + source => "vmll", + params => "def", + expect => <<'#16...........', + # 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 ) ); + } + + This has the comma on the next line exception { + Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) + }, +#16........... + }, + + 'vmll.vmll' => { + source => "vmll", + params => "vmll", + expect => <<'#17...........', + # 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))} + + This has the comma on the next line exception { + Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) + }, +#17........... + }, + + 'vtc1.def' => { + source => "vtc1", + params => "def", + expect => <<'#18...........', +@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 + ], +); +#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........... + }, + }; + + my $ntests = 0 + keys %{$rtests}; + plan tests => $ntests; +} + +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 "<>\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 ); + } +} diff --git a/t/snippets12.t b/t/snippets12.t new file mode 100644 index 00000000..d1a93664 --- /dev/null +++ b/t/snippets12.t @@ -0,0 +1,533 @@ +# **This script was automatically generated** +# Created with: ./make_t.pl +# Tue Jun 12 19:09:24 2018 + +# To locate test #13 for example, search for the string '#13' + +use strict; +use Test; +use Carp; +use Perl::Tidy; +my $rparams; +my $rsources; +my $rtests; + +BEGIN { + + ##################################### + # SECTION 1: Parameter combinations # + ##################################### + $rparams = { + 'def' => "", + 'vtc' => <<'----------', +-sbvtc=2 +-bvtc=2 +-pvtc=2 +---------- + 'wn' => "-wn", + }; + + ###################### + # SECTION 2: Sources # + ###################### + $rsources = { + + 'vtc2' => <<'----------', + ok( + $s->call( + SOAP::Data->name('getStateName') + ->attr( { xmlns => 'urn:/My/Examples' } ), + 1 + )->result eq 'Alabama' + ); +---------- + + 'vtc3' => <<'----------', + $day_long = ( + "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday", "Saturday", "Sunday" + )[$wday]; +---------- + + 'vtc4' => <<'----------', +my$bg_color=$im->colorAllocate(unpack('C3',pack('H2H2H2',unpack('a2a2a2',(length($options_r->{'bg_color'})?$options_r->{'bg_color'}:$MIDI::Opus::BG_color))))); +---------- + + 'wn1' => <<'----------', + my $bg_color = $im->colorAllocate( + unpack( + 'C3', + pack( + 'H2H2H2', + unpack( + 'a2a2a2', + ( + length( $options_r->{'bg_color'} ) + ? $options_r->{'bg_color'} + : $MIDI::Opus::BG_color + ) + ) + ) + ) + ); +---------- + + 'wn2' => <<'----------', +if ($PLATFORM eq 'aix') { + skip_symbols([qw( + Perl_dump_fds + Perl_ErrorNo + Perl_GetVars + PL_sys_intern + )]); +} +---------- + + 'wn3' => <<'----------', +deferred->resolve->then( + sub { + push @out, 'Resolve'; + return $then; + } +)->then( + sub { + push @out, 'Reject'; + push @out, @_; + } +); +---------- + + 'wn4' => <<'----------', +{{{ + # Orignal formatting looks nice but would be hard to duplicate + return exists $G->{ Attr }->{ E } && + exists $G->{ Attr }->{ E }->{ $u } && + exists $G->{ Attr }->{ E }->{ $u }->{ $v } ? + %{ $G->{ Attr }->{ E }->{ $u }->{ $v } } : + ( ); +}}} +---------- + + 'wn5' => <<'----------', +# qw weld with -wn +use_all_ok( + qw{ + PPI + PPI::Tokenizer + PPI::Lexer + PPI::Dumper + PPI::Find + PPI::Normal + PPI::Util + PPI::Cache + } +); +---------- + + 'wn6' => <<'----------', + # illustration of some do-not-weld rules + + # do not weld a two-line function call + $trans->add_transformation( PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); + + # but weld this more complex statement + my $compass = uc( opposite_direction( line_to_canvas_direction( + @{ $coords[0] }, @{ $coords[1] } ) ) ); + + # do not weld to a one-line block because the function could get separated + # from its opening paren + $_[0]->code_handler + ( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); + + # another example; do not weld because the sub is not broken + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + + # but okay to weld here because the sub is broken + $wrapped->add_around_modifier( sub { + push @tracelog => 'around 1'; $_[0]->(); } ); +---------- + }; + + ############################## + # SECTION 3: Expected output # + ############################## + $rtests = { + + 'vtc2.vtc' => { + source => "vtc2", + params => "vtc", + expect => <<'#1...........', + ok( + $s->call( + SOAP::Data->name('getStateName') + ->attr( { xmlns => 'urn:/My/Examples' } ), + 1 )->result eq 'Alabama' ); +#1........... + }, + + 'vtc3.def' => { + source => "vtc3", + params => "def", + expect => <<'#2...........', + $day_long = ( + "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday", "Saturday", "Sunday" + )[$wday]; +#2........... + }, + + 'vtc3.vtc' => { + source => "vtc3", + params => "vtc", + expect => <<'#3...........', + $day_long = ( + "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday", "Saturday", "Sunday" )[$wday]; +#3........... + }, + + 'vtc4.def' => { + source => "vtc4", + params => "def", + expect => <<'#4...........', +my $bg_color = $im->colorAllocate( + unpack( + 'C3', + pack( + 'H2H2H2', + unpack( + 'a2a2a2', + ( + length( $options_r->{'bg_color'} ) + ? $options_r->{'bg_color'} + : $MIDI::Opus::BG_color + ) + ) + ) + ) +); +#4........... + }, + + 'vtc4.vtc' => { + source => "vtc4", + params => "vtc", + expect => <<'#5...........', +my $bg_color = $im->colorAllocate( + unpack( + 'C3', + pack( + 'H2H2H2', + unpack( + 'a2a2a2', + ( + length( $options_r->{'bg_color'} ) + ? $options_r->{'bg_color'} + : $MIDI::Opus::BG_color ) ) ) ) ); +#5........... + }, + + 'wn1.def' => { + source => "wn1", + params => "def", + expect => <<'#6...........', + my $bg_color = $im->colorAllocate( + unpack( + 'C3', + pack( + 'H2H2H2', + unpack( + 'a2a2a2', + ( + length( $options_r->{'bg_color'} ) + ? $options_r->{'bg_color'} + : $MIDI::Opus::BG_color + ) + ) + ) + ) + ); +#6........... + }, + + 'wn1.wn' => { + source => "wn1", + params => "wn", + expect => <<'#7...........', + my $bg_color = $im->colorAllocate( unpack( + 'C3', + pack( + 'H2H2H2', + unpack( + 'a2a2a2', + ( + length( $options_r->{'bg_color'} ) + ? $options_r->{'bg_color'} + : $MIDI::Opus::BG_color + ) + ) + ) + ) ); +#7........... + }, + + 'wn2.def' => { + source => "wn2", + params => "def", + expect => <<'#8...........', +if ( $PLATFORM eq 'aix' ) { + skip_symbols( + [ + qw( + Perl_dump_fds + Perl_ErrorNo + Perl_GetVars + PL_sys_intern + ) + ] + ); +} +#8........... + }, + + 'wn2.wn' => { + source => "wn2", + params => "wn", + expect => <<'#9...........', +if ( $PLATFORM eq 'aix' ) { + skip_symbols( [ qw( + Perl_dump_fds + Perl_ErrorNo + Perl_GetVars + PL_sys_intern + ) ] ); +} +#9........... + }, + + 'wn3.def' => { + source => "wn3", + params => "def", + expect => <<'#10...........', +deferred->resolve->then( + sub { + push @out, 'Resolve'; + return $then; + } +)->then( + sub { + push @out, 'Reject'; + push @out, @_; + } +); +#10........... + }, + + 'wn3.wn' => { + source => "wn3", + params => "wn", + expect => <<'#11...........', +deferred->resolve->then( sub { + push @out, 'Resolve'; + return $then; +} )->then( sub { + push @out, 'Reject'; + push @out, @_; +} ); +#11........... + }, + + 'wn4.def' => { + source => "wn4", + params => "def", + expect => <<'#12...........', +{ + { + { + # Orignal formatting looks nice but would be hard to duplicate + return + exists $G->{Attr}->{E} + && exists $G->{Attr}->{E}->{$u} + && exists $G->{Attr}->{E}->{$u}->{$v} + ? %{ $G->{Attr}->{E}->{$u}->{$v} } + : (); + } + } +} +#12........... + }, + + 'wn4.wn' => { + source => "wn4", + params => "wn", + expect => <<'#13...........', +{ { { + + # Orignal formatting looks nice but would be hard to duplicate + return + exists $G->{Attr}->{E} + && exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v} + ? %{ $G->{Attr}->{E}->{$u}->{$v} } + : (); +} } } +#13........... + }, + + 'wn5.def' => { + source => "wn5", + params => "def", + expect => <<'#14...........', +# qw weld with -wn +use_all_ok( + qw{ + PPI + PPI::Tokenizer + PPI::Lexer + PPI::Dumper + PPI::Find + PPI::Normal + PPI::Util + PPI::Cache + } +); +#14........... + }, + + 'wn5.wn' => { + source => "wn5", + params => "wn", + expect => <<'#15...........', +# qw weld with -wn +use_all_ok( qw{ + PPI + PPI::Tokenizer + PPI::Lexer + PPI::Dumper + PPI::Find + PPI::Normal + PPI::Util + PPI::Cache + } ); +#15........... + }, + + 'wn6.def' => { + source => "wn6", + params => "def", + expect => <<'#16...........', + # illustration of some do-not-weld rules + + # do not weld a two-line function call + $trans->add_transformation( + PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); + + # but weld this more complex statement + my $compass = uc( + opposite_direction( + line_to_canvas_direction( + @{ $coords[0] }, @{ $coords[1] } + ) + ) + ); + + # do not weld to a one-line block because the function could get separated + # from its opening paren + $_[0]->code_handler( + sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); + + # another example; do not weld because the sub is not broken + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + + # but okay to weld here because the sub is broken + $wrapped->add_around_modifier( + sub { + push @tracelog => 'around 1'; + $_[0]->(); + } + ); +#16........... + }, + + 'wn6.wn' => { + source => "wn6", + params => "wn", + expect => <<'#17...........', + # illustration of some do-not-weld rules + + # do not weld a two-line function call + $trans->add_transformation( + PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) ); + + # but weld this more complex statement + my $compass = uc( opposite_direction( line_to_canvas_direction( + @{ $coords[0] }, @{ $coords[1] } + ) ) ); + + # do not weld to a one-line block because the function could get separated + # from its opening paren + $_[0]->code_handler( + sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } ); + + # another example; do not weld because the sub is not broken + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + + # but okay to weld here because the sub is broken + $wrapped->add_around_modifier( sub { + push @tracelog => 'around 1'; + $_[0]->(); + } ); +#17........... + }, + }; + + my $ntests = 0 + keys %{$rtests}; + plan tests => $ntests; +} + +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 "<>\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 ); + } +} diff --git a/t/snippets2.t b/t/snippets2.t index 5ee1bbd0..66b7fc31 100644 --- a/t/snippets2.t +++ b/t/snippets2.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:22 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -18,13 +18,9 @@ BEGIN { # SECTION 1: Parameter combinations # ##################################### $rparams = { - 'bar' => "-bar", - 'boc' => "-boc", - 'ce' => "-cuddled-blocks", - 'ce_wn' => <<'----------', --cuddled-blocks --wn ----------- + 'bar' => "-bar", + 'boc' => "-boc", + 'ce' => "-cuddled-blocks", 'def' => "", }; @@ -33,6 +29,17 @@ BEGIN { ###################### $rsources = { + 'angle' => <<'----------', +# This is an angle operator: +@message_list =sort sort_algorithm < INDEX_FILE >;# angle operator + +# Not an angle operator: +# Patched added in guess routine for this case: +if ( VERSION < 5.009 && $op->name eq 'aassign' ) { +} + +---------- + 'arrows1' => <<'----------', # remove spaces around arrows my $obj = Bio::Variation::AAChange -> new; @@ -170,21 +177,6 @@ elsif($value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/) }else{ $rebase_hash{$name} .= " $site"; } ----------- - - 'ce_wn1' => <<'----------', -if ($BOLD_MATH) { - ( - $labels, $comment, - join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' ) - ) -} -else { - ( - &process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ), - $after - ) -} ---------- }; @@ -193,53 +185,68 @@ else { ############################## $rtests = { + 'angle.def' => { + source => "angle", + params => "def", + expect => <<'#1...........', +# This is an angle operator: +@message_list = sort sort_algorithm < INDEX_FILE >; # angle operator + +# Not an angle operator: +# Patched added in guess routine for this case: +if ( VERSION < 5.009 && $op->name eq 'aassign' ) { +} + +#1........... + }, + 'arrows1.def' => { source => "arrows1", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', # remove spaces around arrows my $obj = Bio::Variation::AAChange->new; my $termcap = Term::Cap->Tgetent( { TERM => undef } ); -#1........... +#2........... }, 'arrows2.def' => { source => "arrows2", params => "def", - expect => <<'#2...........', + expect => <<'#3...........', $_[0]->Blue->backColor( ( $_[0]->Blue->backColor == cl::Blue ) ? cl::LightBlue : cl::Blue ); -#2........... +#3........... }, 'attrib1.def' => { source => "attrib1", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', sub be_careful () : locked method { my $self = shift; # ... } -#3........... +#4........... }, 'attrib2.def' => { source => "attrib2", params => "def", - expect => <<'#4...........', + expect => <<'#5...........', sub witch () # prototype may be on new line, but cannot put line break within prototype : locked { print "and your little dog "; } -#4........... +#5........... }, 'attrib3.def' => { source => "attrib3", params => "def", - expect => <<'#5...........', + expect => <<'#6...........', package Canine; package Dog; @@ -262,34 +269,34 @@ BEGIN { *bar = \&X::foo; } package Z; sub Y::bar : locked; -#5........... +#6........... }, 'bar1.bar' => { source => "bar1", params => "bar", - expect => <<'#6...........', + expect => <<'#7...........', if ( $bigwasteofspace1 && $bigwasteofspace2 || $bigwasteofspace3 && $bigwasteofspace4 ) { } -#6........... +#7........... }, 'bar1.def' => { source => "bar1", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', if ( $bigwasteofspace1 && $bigwasteofspace2 || $bigwasteofspace3 && $bigwasteofspace4 ) { } -#7........... +#8........... }, 'block1.def' => { source => "block1", params => "def", - expect => <<'#8...........', + expect => <<'#9...........', # Some block tests print "start main running\n"; die "main now dying\n"; @@ -303,13 +310,13 @@ BEGIN { $a = 18; print "2nd begin, a=$a\n" } CHECK { $a = 20; print "2nd check, a=$a\n" } END { $a = 23; print "3rd end, a=$a\n" } -#8........... +#9........... }, 'boc1.boc' => { source => "boc1", params => "boc", - expect => <<'#9...........', + expect => <<'#10...........', # RT#98902 # Running with -boc (break-at-old-comma-breakpoints) should not # allow forming a single line @@ -320,26 +327,26 @@ my @bar = map { padding => ( ' ' x $_ ), } } ( 0 .. 32 ); -#9........... +#10........... }, 'boc1.def' => { source => "boc1", params => "def", - expect => <<'#10...........', + expect => <<'#11...........', # RT#98902 # Running with -boc (break-at-old-comma-breakpoints) should not # allow forming a single line my @bar = map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } } ( 0 .. 32 ); -#10........... +#11........... }, 'boc2.boc' => { source => "boc2", params => "boc", - expect => <<'#11...........', + expect => <<'#12...........', my @list = ( 1, 1, 1, @@ -348,75 +355,75 @@ my @list = ( 1, 4, 6, 4, 1, ); -#11........... +#12........... }, 'boc2.def' => { source => "boc2", params => "def", - expect => <<'#12...........', + expect => <<'#13...........', my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, ); -#12........... +#13........... }, 'break1.def' => { source => "break1", params => "def", - expect => <<'#13...........', + expect => <<'#14...........', # break at ; $self->__print("*** Type 'p' now to show start up log\n") ; # XXX add to banner? -#13........... +#14........... }, 'break2.def' => { source => "break2", params => "def", - expect => <<'#14...........', + expect => <<'#15...........', # break before the '->' ( $current_feature_item->children )[0] ->set( $current_feature->primary_tag ); $sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] } ->field_type($_); -#14........... +#15........... }, 'break3.def' => { source => "break3", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # keep the anonymous hash block together: my $red_color = $widget->window->get_colormap->color_alloc( { red => 65000, green => 0, blue => 0 } ); -#15........... +#16........... }, 'break4.def' => { source => "break4", params => "def", - expect => <<'#16...........', + expect => <<'#17...........', spawn( "$LINTIAN_ROOT/unpack/list-binpkg", "$LINTIAN_LAB/info/binary-packages", $v ) == 0 or fail("cannot create binary package list"); -#16........... +#17........... }, 'carat.def' => { source => "carat", params => "def", - expect => <<'#17...........', + expect => <<'#18...........', my $a = ${^WARNING_BITS}; @{^HOWDY_PARDNER} = ( 101, 102 ); ${^W} = 1; $bb[$^]] = "bubba"; -#17........... +#18........... }, 'ce1.ce' => { source => "ce1", params => "ce", - expect => <<'#18...........', + expect => <<'#19...........', # test -ce with blank lines and comments between blocks if ( $value[0] =~ /^(\#)/ ) { # skip any comment line last SWITCH; @@ -436,13 +443,13 @@ if ( $value[0] =~ /^(\#)/ ) { # skip any comment line } else { $rebase_hash{$name} .= " $site"; } -#18........... +#19........... }, 'ce1.def' => { source => "ce1", params => "def", - expect => <<'#19...........', + expect => <<'#20...........', # test -ce with blank lines and comments between blocks if ( $value[0] =~ /^(\#)/ ) { # skip any comment line last SWITCH; @@ -465,20 +472,6 @@ elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ ) else { $rebase_hash{$name} .= " $site"; } -#19........... - }, - - 'ce_wn1.ce_wn' => { - source => "ce_wn1", - params => "ce_wn", - expect => <<'#20...........', -if ($BOLD_MATH) { ( - $labels, $comment, - join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' ) -) } else { ( - &process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ), - $after -) } #20........... }, }; diff --git a/t/snippets3.t b/t/snippets3.t index 6c94b9ef..f016401f 100644 --- a/t/snippets3.t +++ b/t/snippets3.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -18,6 +18,10 @@ BEGIN { # SECTION 1: Parameter combinations # ##################################### $rparams = { + 'ce_wn' => <<'----------', +-cuddled-blocks +-wn +---------- 'colin' => <<'----------', -l=0 -pt=2 @@ -52,7 +56,6 @@ BEGIN { 'essential2' => "-extrude", 'extrude' => "--extrude", 'fabrice_bug' => "-bt=0", - 'gnu' => "-gnu", }; ###################### @@ -226,10 +229,24 @@ $_, $val ############################## $rtests = { + 'ce_wn1.ce_wn' => { + source => "ce_wn1", + params => "ce_wn", + expect => <<'#1...........', +if ($BOLD_MATH) { ( + $labels, $comment, + join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' ) +) } else { ( + &process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ), + $after +) } +#1........... + }, + 'ce_wn1.def' => { source => "ce_wn1", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', if ($BOLD_MATH) { ( $labels, $comment, @@ -242,26 +259,26 @@ else { $after ) } -#1........... +#2........... }, 'colin.colin' => { source => "colin", params => "colin", - expect => <<'#2...........', + expect => <<'#3...........', env(0, 15, 0, 10, { Xtitle => 'X-data', Ytitle => 'Y-data', Title => 'An example of errb and points', Font => 'Italic' }); -#2........... +#3........... }, 'colin.def' => { source => "colin", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', env( 0, 15, 0, 10, { @@ -271,13 +288,13 @@ env( Font => 'Italic' } ); -#3........... +#4........... }, 'essential.def' => { source => "essential", params => "def", - expect => <<'#4...........', + expect => <<'#5...........', # Run with mangle to squeeze out the white space # also run with extrude @@ -345,13 +362,13 @@ use Mail::Internet 1.28 (); # it may turn into a function evaluation, like here # between '&' and 'O_ACCMODE', producing a syntax error [File.pm] $opts{rdonly} = ( ( $opts{mode} & O_ACCMODE ) == O_RDONLY ); -#4........... +#5........... }, 'essential.essential1' => { source => "essential", params => "essential1", - expect => <<'#5...........', + expect => <<'#6...........', # Run with mangle to squeeze out the white space # also run with extrude # never combine two bare words or numbers @@ -397,13 +414,13 @@ use Mail::Internet 1.28 (); # it may turn into a function evaluation, like here # between '&' and 'O_ACCMODE', producing a syntax error [File.pm] $opts{rdonly}=(($opts{mode}& O_ACCMODE)==O_RDONLY); -#5........... +#6........... }, 'essential.essential2' => { source => "essential", params => "essential2", - expect => <<'#6...........', + expect => <<'#7...........', # Run with mangle to squeeze out the white space # also run with extrude # never combine two bare words or numbers @@ -574,44 +591,44 @@ O_ACCMODE O_RDONLY ) ; -#6........... +#7........... }, 'extrude1.def' => { source => "extrude1", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', # do not break before the ++ print $x++ . "\n"; -#7........... +#8........... }, 'extrude1.extrude' => { source => "extrude1", params => "extrude", - expect => <<'#8...........', + expect => <<'#9...........', # do not break before the ++ print$x++ . "\n" ; -#8........... +#9........... }, 'extrude2.def' => { source => "extrude2", params => "def", - expect => <<'#9...........', + expect => <<'#10...........', if ( -l pid_filename() ) { return readlink( pid_filename() ); } -#9........... +#10........... }, 'extrude2.extrude' => { source => "extrude2", params => "extrude", - expect => <<'#10...........', + expect => <<'#11...........', if ( -l pid_filename( @@ -626,25 +643,25 @@ pid_filename( ) ; } -#10........... +#11........... }, 'extrude3.def' => { source => "extrude3", params => "def", - expect => <<'#11...........', + expect => <<'#12...........', # Breaking before a ++ can cause perl to guess wrong print( ( $i++ & 1 ) ? $_ : ( $change{$_} || $_ ) ); # Space between '&' and 'O_ACCMODE' is essential here $opts{rdonly} = ( ( $opts{mode} & O_ACCMODE ) == O_RDONLY ); -#11........... +#12........... }, 'extrude3.extrude' => { source => "extrude3", params => "extrude", - expect => <<'#12...........', + expect => <<'#13...........', # Breaking before a ++ can cause perl to guess wrong print ( @@ -678,26 +695,26 @@ O_ACCMODE O_RDONLY ) ; -#12........... +#13........... }, 'extrude4.def' => { source => "extrude4", params => "def", - expect => <<'#13...........', + expect => <<'#14...........', # From Safe.pm caused trouble with extrude use Opcode 1.01, qw( opset opset_to_ops opmask_add empty_opset full_opset invert_opset verify_opset opdesc opcodes opmask define_optag opset_to_hex ); -#13........... +#14........... }, 'extrude4.extrude' => { source => "extrude4", params => "extrude", - expect => <<'#14...........', + expect => <<'#15...........', # From Safe.pm caused trouble with extrude use Opcode @@ -709,33 +726,33 @@ empty_opset full_opset invert_opset verify_opset opdesc opcodes opmask define_optag opset_to_hex ) ; -#14........... +#15........... }, 'fabrice_bug.def' => { source => "fabrice_bug", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # no space around ^variable with -bt=0 my $before = ${^PREMATCH}; my $after = ${PREMATCH}; -#15........... +#16........... }, 'fabrice_bug.fabrice_bug' => { source => "fabrice_bug", params => "fabrice_bug", - expect => <<'#16...........', + expect => <<'#17...........', # no space around ^variable with -bt=0 my $before = ${^PREMATCH}; my $after = ${ PREMATCH }; -#16........... +#17........... }, 'format1.def' => { source => "format1", params => "def", - expect => <<'#17...........', + expect => <<'#18...........', if (/^--list$/o) { format = @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -747,13 +764,13 @@ $_, $val write; } } -#17........... +#18........... }, 'given1.def' => { source => "given1", params => "def", - expect => <<'#18...........', + expect => <<'#19...........', given ( [ 9, "a", 11 ] ) { when (qr/\d/) { given ($count) { @@ -765,29 +782,17 @@ $_, $val } ok(1) when 11; } -#18........... +#19........... }, 'gnu1.def' => { source => "gnu1", params => "def", - expect => <<'#19...........', + expect => <<'#20...........', @common_sometimes = ( "aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot", "stamp-h.in", 'stamp-vti' ); -#19........... - }, - - 'gnu1.gnu' => { - source => "gnu1", - params => "gnu", - expect => <<'#20...........', -@common_sometimes = ( - "aclocal.m4", "acconfig.h", - "config.h.top", "config.h.bot", - "stamp-h.in", 'stamp-vti' - ); #20........... }, }; diff --git a/t/snippets4.t b/t/snippets4.t index a0b6783a..a1e3e871 100644 --- a/t/snippets4.t +++ b/t/snippets4.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -32,6 +32,13 @@ BEGIN { ###################### $rsources = { + 'gnu1' => <<'----------', +@common_sometimes = ( + "aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot", + "stamp-h.in", 'stamp-vti' +); +---------- + 'gnu2' => <<'----------', $search_mb = $menu_bar->Menubutton( '-text' => 'Search', @@ -142,15 +149,6 @@ redo LOOP if/\G[A-Z][a-z]+\b[,.;]?\s*/gc; print(" MiXeD"),redo LOOP if/\G[A-Za-z]+\b[,.;]?\s*/gc;print( " alphanumeric"),redo LOOP if/\G[A-Za-z0-9]+\b[,.;]?\s*/gc;print(" line-noise" ),redo LOOP if/\G[^A-Za-z0-9]+/gc;print". That's all!\n";} ----------- - - 'list1' => <<'----------', -%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61, - "archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6, - "11x17",43.2, "ledger",27.9); -%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7, - "archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14, - "11x17",27.9, "ledger",43.2); ---------- }; @@ -159,10 +157,22 @@ print(" MiXeD"),redo LOOP if/\G[A-Za-z]+\b[,.;]?\s*/gc;print( ############################## $rtests = { + 'gnu1.gnu' => { + source => "gnu1", + params => "gnu", + expect => <<'#1...........', +@common_sometimes = ( + "aclocal.m4", "acconfig.h", + "config.h.top", "config.h.bot", + "stamp-h.in", 'stamp-vti' + ); +#1........... + }, + 'gnu2.def' => { source => "gnu2", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', $search_mb = $menu_bar->Menubutton( '-text' => 'Search', '-relief' => 'raised', @@ -171,26 +181,26 @@ $search_mb = $menu_bar->Menubutton( '-side' => 'left', '-padx' => 2 ); -#1........... +#2........... }, 'gnu2.gnu' => { source => "gnu2", params => "gnu", - expect => <<'#2...........', + expect => <<'#3...........', $search_mb = $menu_bar->Menubutton( '-text' => 'Search', '-relief' => 'raised', '-borderwidth' => 2, )->pack('-side' => 'left', '-padx' => 2); -#2........... +#3........... }, 'gnu3.def' => { source => "gnu3", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', $output_rules .= &file_contents_with_transform( 's/\@TEXI\@/' . $info_cursor . '/g; ' @@ -202,13 +212,13 @@ $output_rules .= &file_contents_with_transform( . $conf_pat . ',g;', 'texi-vers' ); -#3........... +#4........... }, 'gnu3.gnu' => { source => "gnu3", params => "gnu", - expect => <<'#4...........', + expect => <<'#5...........', $output_rules .= &file_contents_with_transform( 's/\@TEXI\@/' @@ -221,41 +231,41 @@ $output_rules .= . $conf_pat . ',g;', 'texi-vers' ); -#4........... +#5........... }, 'gnu4.def' => { source => "gnu4", params => "def", - expect => <<'#5...........', + expect => <<'#6...........', my $mzef = Bio::Tools::MZEF->new( '-file' => Bio::Root::IO->catfile( "t", "genomic-seq.mzef" ) ); -#5........... +#6........... }, 'gnu4.gnu' => { source => "gnu4", params => "gnu", - expect => <<'#6...........', + expect => <<'#7...........', my $mzef = Bio::Tools::MZEF->new( '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef")); -#6........... +#7........... }, 'hanging_side_comments1.def' => { source => "hanging_side_comments1", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', $valuestr .= $value . " "; # with a trailing space in case there are multiple values # for this tag (allowed in GFF2 and .ace format) -#7........... +#8........... }, 'hanging_side_comments2.def' => { source => "hanging_side_comments2", params => "def", - expect => <<'#8...........', + expect => <<'#9...........', # keep '=' lined up even with hanging side comments $ax = 1; # side comment # hanging side comment @@ -263,13 +273,13 @@ $boondoggle = 5; # side comment $beetle = 5; # side comment # hanging side comment $d = 3; -#8........... +#9........... }, 'hash1.def' => { source => "hash1", params => "def", - expect => <<'#9...........', + expect => <<'#10...........', %TV = ( flintstones => { series => "flintstones", @@ -315,40 +325,40 @@ $d = 3; ], }, ); -#9........... +#10........... }, 'hashbang.def' => { source => "hashbang", params => "def", - expect => <<'#10...........', + expect => <<'#11...........', #!/usr/bin/perl -#10........... +#11........... }, 'here1.def' => { source => "here1", params => "def", - expect => <<'#11...........', + expect => <<'#12...........', is( <<~`END`, "ok\n", '<<~`HEREDOC`' ); $Perl -le "print 'ok'" END -#11........... +#12........... }, 'html1.def' => { source => "html1", params => "def", - expect => <<'#12...........', + expect => <<'#13...........', if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" } else { $editlblk = "off"; $editlblkchecked = "unchecked" } -#12........... +#13........... }, 'html1.html' => { source => "html1", params => "html", - expect => <<'#13...........', + expect => <<'#14...........', @@ -396,13 +406,13 @@ pre { color: #000000; -#13........... +#14........... }, 'ident1.def' => { source => "ident1", params => "def", - expect => <<'#14...........', + expect => <<'#15...........', package A; sub new { @@ -414,46 +424,46 @@ package main; my $scanner = new A::(); $scanner = new A::; $scanner = new A 'a'; -#14........... +#15........... }, 'if1.def' => { source => "if1", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # one-line blocks if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" } else { $editlblk = "off"; $editlblkchecked = "unchecked" } -#15........... +#16........... }, 'iscl1.def' => { source => "iscl1", params => "def", - expect => <<'#16...........', + expect => <<'#17...........', # -iscl will not allow alignment of hanging side comments (currently) $gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for # dev, but be more forgiving # for releases -#16........... +#17........... }, 'iscl1.iscl' => { source => "iscl1", params => "iscl", - expect => <<'#17...........', + expect => <<'#18...........', # -iscl will not allow alignment of hanging side comments (currently) $gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for # dev, but be more forgiving # for releases -#17........... +#18........... }, 'label1.def' => { source => "label1", params => "def", - expect => <<'#18...........', + expect => <<'#19...........', INIT: { $a++; print "looping with label INIT:, a=$a\n"; @@ -465,13 +475,13 @@ package: { sub: { print "hello!\n"; } -#18........... +#19........... }, 'lextest1.def' => { source => "lextest1", params => "def", - expect => <<'#19...........', + expect => <<'#20...........', $_ = <<'EOL'; $url = new URI::URL "http://www/"; die if $url eq "xXx"; EOL @@ -485,25 +495,6 @@ LOOP: { print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/gc; print ". That's all!\n"; } -#19........... - }, - - 'list1.def' => { - source => "list1", - params => "def", - expect => <<'#20...........', -%height = ( - "letter", 27.9, "legal", 35.6, "arche", 121.9, - "archd", 91.4, "archc", 61, "archb", 45.7, - "archa", 30.5, "flsa", 33, "flse", 33, - "halfletter", 21.6, "11x17", 43.2, "ledger", 27.9 -); -%width = ( - "letter", 21.6, "legal", 21.6, "arche", 91.4, - "archd", 61, "archc", 45.7, "archb", 30.5, - "archa", 22.9, "flsa", 21.6, "flse", 21.6, - "halfletter", 14, "11x17", 27.9, "ledger", 43.2 -); #20........... }, }; diff --git a/t/snippets5.t b/t/snippets5.t index 4ba7ba15..3419b8a7 100644 --- a/t/snippets5.t +++ b/t/snippets5.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -23,11 +23,6 @@ BEGIN { 'mangle' => "--mangle", 'nasc' => "-nasc", 'nothing' => "", - 'otr' => <<'----------', --ohbr --opr --osbr ----------- }; ###################### @@ -35,6 +30,15 @@ BEGIN { ###################### $rsources = { + 'list1' => <<'----------', +%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61, + "archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6, + "11x17",43.2, "ledger",27.9); +%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7, + "archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14, + "11x17",27.9, "ledger",43.2); +---------- + 'listop1' => <<'----------', my @sorted = map { $_->[0] } sort { $a->[1] <=> $b->[1] } @@ -307,29 +311,48 @@ return $pdl->slice( ############################## $rtests = { + 'list1.def' => { + source => "list1", + params => "def", + expect => <<'#1...........', +%height = ( + "letter", 27.9, "legal", 35.6, "arche", 121.9, + "archd", 91.4, "archc", 61, "archb", 45.7, + "archa", 30.5, "flsa", 33, "flse", 33, + "halfletter", 21.6, "11x17", 43.2, "ledger", 27.9 +); +%width = ( + "letter", 21.6, "legal", 21.6, "arche", 91.4, + "archd", 61, "archc", 45.7, "archb", 30.5, + "archa", 22.9, "flsa", 21.6, "flse", 21.6, + "halfletter", 14, "11x17", 27.9, "ledger", 43.2 +); +#1........... + }, + 'listop1.def' => { source => "listop1", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', my @sorted = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list; -#1........... +#2........... }, 'listop2.def' => { source => "listop2", params => "def", - expect => <<'#2...........', + expect => <<'#3...........', my @sorted = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list; -#2........... +#3........... }, 'lp1.def' => { source => "lp1", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', # a good test problem for -lp; thanks to Ian Stuart push @contents, $c->table( @@ -482,13 +505,13 @@ push @contents, ) ), ); -#3........... +#4........... }, 'lp1.lp' => { source => "lp1", params => "lp", - expect => <<'#4...........', + expect => <<'#5...........', # a good test problem for -lp; thanks to Ian Stuart push @contents, $c->table( @@ -641,31 +664,31 @@ push @contents, ) ), ); -#4........... +#5........... }, 'mangle1.def' => { source => "mangle1", params => "def", - expect => <<'#5...........', + expect => <<'#6...........', # The space after the '?' is essential and must not be deleted print $::opt_m ? " Files: " . my_wrap( "", " ", $v ) : $v; -#5........... +#6........... }, 'mangle1.mangle' => { source => "mangle1", params => "mangle", - expect => <<'#6...........', + expect => <<'#7...........', # The space after the '?' is essential and must not be deleted print$::opt_m ? " Files: ".my_wrap(""," ",$v):$v; -#6........... +#7........... }, 'mangle2.def' => { source => "mangle2", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', # hanging side comments - do not remove leading space with -mangle if ( $size1 == 0 || $size2 == 0 ) { # special handling for zero-length if ( $size2 + $size1 == 0 ) { # files. @@ -685,13 +708,13 @@ if ( $size1 == 0 || $size2 == 0 ) { # special handling for zero-length } } -#7........... +#8........... }, 'mangle2.mangle' => { source => "mangle2", params => "mangle", - expect => <<'#8...........', + expect => <<'#9...........', # hanging side comments - do not remove leading space with -mangle if($size1==0||$size2==0){# special handling for zero-length if($size2+$size1==0){# files. @@ -703,13 +726,13 @@ exit 0;}else{# Can't we say 'differ at byte zero' # filesize. if($volume){warn"$0: EOF on $file1\n" unless$size1; warn"$0: EOF on $file2\n" unless$size2;}exit 1;}} -#8........... +#9........... }, 'mangle3.def' => { source => "mangle3", params => "def", - expect => <<'#9...........', + expect => <<'#10...........', # run with --mangle # Troublesome punctuation variables: $$ and $# @@ -732,13 +755,13 @@ if ( $arc >= - CAKE && $arc <= CAKE ) { # do not remove the space after 'JUNK': print JUNK ( "<", "&", ">" )[ rand(3) ]; # make these a bit more likely -#9........... +#10........... }, 'mangle3.mangle' => { source => "mangle3", params => "mangle", - expect => <<'#10...........', + expect => <<'#11...........', # run with --mangle # Troublesome punctuation variables: $$ and $# # don't delete ws between '$$' and 'if' @@ -755,13 +778,13 @@ use constant CAKE=>atan2(1,1)/2; if($arc>=- CAKE&&$arc<=CAKE){} # do not remove the space after 'JUNK': print JUNK ("<","&",">")[rand(3)];# make these a bit more likely -#10........... +#11........... }, 'math1.def' => { source => "math1", params => "def", - expect => <<'#11...........', + expect => <<'#12...........', my $xyz_shield = [ [ -0.060, -0.060, 0. ], [ 0.060, -0.060, 0. ], @@ -772,13 +795,13 @@ my $xyz_shield = [ [ 0.0925, 0.0925, 0.092 ], [ -0.0925, 0.0925, 0.092 ], ]; -#11........... +#12........... }, 'math2.def' => { source => "math2", params => "def", - expect => <<'#12...........', + expect => <<'#13...........', $ans = pdl( [ 0, 0, 0, 0, 0 ], [ 0, 0, 2, 0, 0 ], @@ -786,13 +809,13 @@ $ans = pdl( [ 0, 0, 4, 0, 0 ], [ 0, 0, 0, 0, 0 ] ); -#12........... +#13........... }, 'math3.def' => { source => "math3", params => "def", - expect => <<'#13...........', + expect => <<'#14...........', my ( $x, $y ) = ( $x0 + $index_x * $xgridwidth * $xm + @@ -801,13 +824,13 @@ $ans = pdl( $index_y * $ygridwidth * $ym - ( $map_y * $ym * $ygridwidth ) / $detailheight, ); -#13........... +#14........... }, 'math4.def' => { source => "math4", params => "def", - expect => <<'#14...........', + expect => <<'#15...........', my $u = ( $range * $pratio**( 1. / 3. ) ) / $wratio; my $factor = exp( -( 18 / $u )**4 ); my $ovp = @@ -817,49 +840,49 @@ my $impulse = ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor; $ovp = $ovp * $pratio; $impulse = $impulse * $wratio * $pratio**( 2 / 3 ); -#14........... +#15........... }, 'nasc.def' => { source => "nasc", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # will break and add semicolon unless -nasc is given eval { $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; }; -#15........... +#16........... }, 'nasc.nasc' => { source => "nasc", params => "nasc", - expect => <<'#16...........', + expect => <<'#17...........', # will break and add semicolon unless -nasc is given eval { $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } }; -#16........... +#17........... }, 'nothing.def' => { source => "nothing", params => "def", - expect => <<'#17...........', -#17........... + expect => <<'#18...........', +#18........... }, 'nothing.nothing' => { source => "nothing", params => "nothing", - expect => <<'#18...........', -#18........... + expect => <<'#19...........', +#19........... }, 'otr1.def' => { source => "otr1", params => "def", - expect => <<'#19...........', + expect => <<'#20...........', return $pdl->slice( join ',', ( @@ -871,23 +894,6 @@ return $pdl->slice( } @_ ) ); -#19........... - }, - - 'otr1.otr' => { - source => "otr1", - params => "otr", - expect => <<'#20...........', -return $pdl->slice( - join ',', ( - map { - $_ eq "X" ? ":" - : ref $_ eq "ARRAY" ? join ':', @$_ - : !ref $_ ? $_ - : die "INVALID SLICE DEF $_" - } @_ - ) -); #20........... }, }; diff --git a/t/snippets6.t b/t/snippets6.t index 81f6eb02..fb3bcad4 100644 --- a/t/snippets6.t +++ b/t/snippets6.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -19,6 +19,11 @@ BEGIN { ##################################### $rparams = { 'def' => "", + 'otr' => <<'----------', +-ohbr +-opr +-osbr +---------- 'pbp' => "-pbp -nst -nse", }; @@ -27,6 +32,20 @@ BEGIN { ###################### $rsources = { + 'otr1' => <<'----------', +return $pdl->slice( + join ',', + ( + map { + $_ eq "X" ? ":" + : ref $_ eq "ARRAY" ? join ':', @$_ + : !ref $_ ? $_ + : die "INVALID SLICE DEF $_" + } @_ + ) +); +---------- + 'pbp1' => <<'----------', # break after '+' if default, before + if pbp my $min_gnu_indentation = $standard_increment + @@ -111,40 +130,12 @@ $retarray = $delta_time = sprintf "%.4f", ( ( $done[0] + ( $done[1] / 1e6 ) ) - ( $start[0] + ( $start[1] / 1e6 ) ) ); ---------- - 'rt102451' => <<'----------', -# RT#102451 bug test; unwanted spaces added before =head1 on each pass -#<<< - -=head1 NAME - -=cut - -my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array - - -=head1 NAME - -=cut - -#>>> + 'rt101547' => <<'----------', +{ source_host => MM::Config->instance->host // q{}, } ---------- - 'rt116344' => <<'----------', -# Rt116344 -# Attempting to tidy the following code failed: -sub broken { - return ref {} ? 1 : 0; - something(); -} ----------- - - 'rt123774' => <<'----------', -# retain any space between backslash and quote to avoid fooling html formatters -my $var1 = \ "bubba"; -my $var2 = \"bubba"; -my $var3 = \ 'bubba'; -my $var4 = \'bubba'; -my $var5 = \ "bubba"; + 'rt102371' => <<'----------', +state $b //= ccc(); ---------- }; @@ -153,102 +144,119 @@ my $var5 = \ "bubba"; ############################## $rtests = { + 'otr1.otr' => { + source => "otr1", + params => "otr", + expect => <<'#1...........', +return $pdl->slice( + join ',', ( + map { + $_ eq "X" ? ":" + : ref $_ eq "ARRAY" ? join ':', @$_ + : !ref $_ ? $_ + : die "INVALID SLICE DEF $_" + } @_ + ) +); +#1........... + }, + 'pbp1.def' => { source => "pbp1", params => "def", - expect => <<'#1...........', + expect => <<'#2...........', # break after '+' if default, before + if pbp my $min_gnu_indentation = $standard_increment + $gnu_stack[$max_gnu_stack_index]->get_SPACES(); -#1........... +#2........... }, 'pbp1.pbp' => { source => "pbp1", params => "pbp", - expect => <<'#2...........', + expect => <<'#3...........', # break after '+' if default, before + if pbp my $min_gnu_indentation = $standard_increment + $gnu_stack[$max_gnu_stack_index]->get_SPACES(); -#2........... +#3........... }, 'pbp2.def' => { source => "pbp2", params => "def", - expect => <<'#3...........', + expect => <<'#4...........', $tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4; -#3........... +#4........... }, 'pbp2.pbp' => { source => "pbp2", params => "pbp", - expect => <<'#4...........', + expect => <<'#5...........', $tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4; -#4........... +#5........... }, 'pbp3.def' => { source => "pbp3", params => "def", - expect => <<'#5...........', + expect => <<'#6...........', return $sec + $SecOff + ( SECS_PER_MINUTE * $min ) + ( SECS_PER_HOUR * $hour ) + ( SECS_PER_DAY * $days ); -#5........... +#6........... }, 'pbp3.pbp' => { source => "pbp3", params => "pbp", - expect => <<'#6...........', + expect => <<'#7...........', return $sec + $SecOff + ( SECS_PER_MINUTE * $min ) + ( SECS_PER_HOUR * $hour ) + ( SECS_PER_DAY * $days ); -#6........... +#7........... }, 'pbp4.def' => { source => "pbp4", params => "def", - expect => <<'#7...........', + expect => <<'#8...........', # with defaults perltidy will break after the '=' here my @host_seq = $level eq "easy" ? @reordered : 0 .. $last; # reordered has CDROM up front -#7........... +#8........... }, 'pbp4.pbp' => { source => "pbp4", params => "pbp", - expect => <<'#8...........', + expect => <<'#9...........', # with defaults perltidy will break after the '=' here my @host_seq = $level eq "easy" ? @reordered : 0 .. $last; # reordered has CDROM up front -#8........... +#9........... }, 'pbp5.def' => { source => "pbp5", params => "def", - expect => <<'#9...........', + expect => <<'#10...........', # illustates problem with -pbp: -ci should not equal -i say 'ok_200_24_hours.value ' . average( @@ -258,13 +266,13 @@ say 'ok_200_24_hours.value ' } ); -#9........... +#10........... }, 'pbp5.pbp' => { source => "pbp5", params => "pbp", - expect => <<'#10...........', + expect => <<'#11...........', # illustates problem with -pbp: -ci should not equal -i say 'ok_200_24_hours.value ' . average( @@ -274,13 +282,13 @@ say 'ok_200_24_hours.value ' } ); -#10........... +#11........... }, 'print1.def' => { source => "print1", params => "def", - expect => <<'#11...........', + expect => <<'#12...........', # same text twice. Has uncontained commas; -- leave as is print "conformability (Not the same dimension)\n", "\t", @@ -292,122 +300,90 @@ print "\t", $have, " is ", text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n", ; -#11........... +#12........... }, 'q1.def' => { source => "q1", params => "def", - expect => <<'#12...........', + expect => <<'#13...........', print qq(You are in zone $thisTZ Difference with respect to GMT is ), $offset / 3600, qq( hours And local time is $hour hours $min minutes $sec seconds ); -#12........... +#13........... }, 'q2.def' => { source => "q2", params => "def", - expect => <<'#13...........', + expect => <<'#14...........', $a = qq XHello World\nX; print "$a"; -#13........... +#14........... }, 'recombine1.def' => { source => "recombine1", params => "def", - expect => <<'#14...........', + expect => <<'#15...........', # recombine '= [' here: $retarray = [ &{ $sth->{'xbase_parsed_sql'}{'selectfn'} } ( $xbase, $values, $sth->{'xbase_bind_values'} ) ] if defined $values; -#14........... +#15........... }, 'recombine2.def' => { source => "recombine2", params => "def", - expect => <<'#15...........', + expect => <<'#16...........', # recombine = unless old break there $a = [ length( $self->{fb}[-1] ), $#{ $self->{fb} } ] ; # set cursor at end of buffer and print this cursor -#15........... +#16........... }, 'recombine3.def' => { source => "recombine3", params => "def", - expect => <<'#16...........', + expect => <<'#17...........', # recombine final line $command = ( ( $catpage =~ m:\.gz: ) ? $ZCAT : $CAT ) . " < $catpage"; -#16........... +#17........... }, 'recombine4.def' => { source => "recombine4", params => "def", - expect => <<'#17...........', + expect => <<'#18...........', # do not recombine into two lines after a comma if # the term is complex (has parens) or changes level $delta_time = sprintf "%.4f", ( ( $done[0] + ( $done[1] / 1e6 ) ) - ( $start[0] + ( $start[1] / 1e6 ) ) ); -#17........... - }, - - 'rt102451.def' => { - source => "rt102451", - params => "def", - expect => <<'#18...........', -# RT#102451 bug test; unwanted spaces added before =head1 on each pass -#<<< - -=head1 NAME - -=cut - -my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array - - -=head1 NAME - -=cut - -#>>> #18........... }, - 'rt116344.def' => { - source => "rt116344", + 'rt101547.def' => { + source => "rt101547", params => "def", expect => <<'#19...........', -# Rt116344 -# Attempting to tidy the following code failed: -sub broken { - return ref {} ? 1 : 0; - something(); -} +{ source_host => MM::Config->instance->host // q{}, } #19........... }, - 'rt123774.def' => { - source => "rt123774", + 'rt102371.def' => { + source => "rt102371", params => "def", expect => <<'#20...........', -# retain any space between backslash and quote to avoid fooling html formatters -my $var1 = \ "bubba"; -my $var2 = \"bubba"; -my $var3 = \ 'bubba'; -my $var4 = \'bubba'; -my $var5 = \ "bubba"; +state $b //= ccc(); #20........... }, }; diff --git a/t/snippets7.t b/t/snippets7.t index 5252c2d9..ecf5ac39 100644 --- a/t/snippets7.t +++ b/t/snippets7.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -19,32 +19,21 @@ BEGIN { ##################################### $rparams = { 'def' => "", - 'rt125012' => <<'----------', --mangle + 'rt107832' => <<'----------', +-lp +-boc +---------- + 'rt111519' => <<'----------', +-io -dac ---------- - '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 + 'rt113689' => <<'----------', +-blao=2 +-blbc=1 +-blaol='*' +-blbcl='*' ---------- + 'rt119970' => "-wn", }; ###################### @@ -52,276 +41,161 @@ BEGIN { ###################### $rsources = { - 'rt125012' => <<'----------', -++$_ for -#one space before eol: -values %_; -system -#one space before eol: -qq{}; ----------- + 'rt102451' => <<'----------', +# RT#102451 bug test; unwanted spaces added before =head1 on each pass +#<<< - 'rt94338' => <<'----------', -# for-loop in a parenthesized block-map triggered an error message -map( { foreach my $item ( '0', '1' ) { print $item} } qw(a b c) ); ----------- +=head1 NAME - 'rt96101' => <<'----------', -# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine -# references inside subroutine execution. - -# closing brace of second sub should get outdented here -sub startup { - my $self = shift; - $self->plugin( - 'authentication' => { - 'autoload_user' => 1, - 'session_key' => rand(), - 'load_user' => sub { - return HaloVP::Users->load(@_); - }, - 'validate_user' => sub { - return HaloVP::Users->login(@_); - } - } - ); -} +=cut ----------- +my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array + + +=head1 NAME - '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"; +=cut + +#>>> ---------- - 'semicolon2' => <<'----------', - # will not add semicolon for this block type - $highest = List::Util::reduce { Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b } + 'rt104427' => <<'----------', +#!/usr/bin/env perl +use v5.020; #includes strict +use warnings; +use experimental 'signatures'; +setidentifier(); +exit; +sub setidentifier ( $href = {} ) { say 'hi'; } ---------- - '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 + 'rt106492' => <<'----------', +my $ct = Courriel::Header::ContentType->new( mime_type => 'multipart/alternative', attributes => { boundary => unique_boundary }, ); ---------- - 'sil1' => <<'----------', -############################################################# - # This will walk to the left because of bad -sil guess - SKIP: { -############################################################# - } + 'rt107832' => <<'----------', +my %temp = +( +supsup => 123, +nested => { +asdf => 456, +yarg => 'yarp', +}, ); +---------- -# This will walk to the right if it is the first line of a file. + 'rt111519' => <<'----------', +use strict; +use warnings; +my $x = 1; # comment not removed +# comment will be removed +my $y = 2; # comment also not removed +---------- - 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; + 'rt112534' => <<'----------', +get( on_ready => sub ($worker) { $on_ready->end; return; }, on_exit => sub ( $worker, $status ) { return; }, on_data => sub ($data) { $self->_on_data(@_) if $self; return; } ); +---------- + 'rt113689' => <<'----------', +$a = sub { + if ( !defined( $_[0] ) ) { + print("Hello, World\n"); + } + else { print( $_[0], "\n" ); } +}; ---------- - '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' =~ //; + 'rt113792' => <<'----------', +print "hello world\n"; +__DATA__ +=> 1/2 : 0.5 ---------- - '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; + 'rt114359' => <<'----------', +my $x = 2; print $x ** 0.5; ---------- - 'space1' => <<'----------', - # We usually want a space at '} (', for example: - map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s ); + 'rt114909' => <<'----------', +#!perl +use strict; +use warnings; + +use experimental 'signatures'; + +sub reader ( $line_sep, $chomp ) { + return sub ( $fh, $out ) : prototype(*$) { + local $/ = $line_sep; + my $content = <$fh>; + return undef unless defined $content; + chomp $content if $chomp; + $$out .= $content; + return 1; + }; +} - # But not others: - &{ $_->[1] }( delete $_[$#_]{ $_->[0] } ); +BEGIN { + *get_line = reader( "\n", 1 ); +} - # remove unwanted spaces after $ and -> here - &{ $ _ -> [1] }( delete $ _ [$#_ ]{ $_ -> [0] } ); +while ( get_line( STDIN, \my $buf ) ) { + print "Got: $buf\n"; +} ---------- - 'space2' => <<'----------', -# space before this opening paren -for$i(0..20){} - -# retain any space between '-' and bare word -$myhash{USER-NAME}='steve'; + 'rt116344' => <<'----------', +# Rt116344 +# Attempting to tidy the following code failed: +sub broken { + return ref {} ? 1 : 0; + something(); +} ---------- - 'space3' => <<'----------', -# Treat newline as a whitespace. Otherwise, we might combine -# 'Send' and '-recipients' here -my $msg = new Fax::Send - -recipients => $to, - -data => $data; + 'rt119140' => <<'----------', +while (<<>>) { } ---------- - '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/'); + 'rt119588' => <<'----------', +sub demo { + my $self = shift; + my $longname = shift // "xyz"; +} ---------- - '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/'); - + 'rt119970' => <<'----------', +my $x = [ + { + fooxx => 1, + bar => 1, + } +]; ---------- - '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?")))); + 'rt123492' => <<'----------', +if (1) { + print <<~EOF; + Hello there + EOF +} ---------- - '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 - } + 'rt123749' => <<'----------', +get('http://mojolicious.org')->then( + sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); } -} - +)->then( + sub { + my $cpan = shift; + say $cpan->res->code; + } +)->catch( + sub { + my $err = shift; + warn "Something went wrong: $err"; + } +)->wait; ---------- }; @@ -330,481 +204,290 @@ sub arrange_topframe { ############################## $rtests = { - 'rt125012.def' => { - source => "rt125012", + 'rt102451.def' => { + source => "rt102451", params => "def", expect => <<'#1...........', -++$_ for +# RT#102451 bug test; unwanted spaces added before =head1 on each pass +#<<< - #one space before eol: - values %_; -system +=head1 NAME - #one space before eol: - qq{}; +=cut + +my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array + + +=head1 NAME + +=cut + +#>>> #1........... }, - 'rt125012.rt125012' => { - source => "rt125012", - params => "rt125012", + 'rt104427.def' => { + source => "rt104427", + params => "def", expect => <<'#2...........', -++$_ for values%_; -system qq{}; +#!/usr/bin/env perl +use v5.020; #includes strict +use warnings; +use experimental 'signatures'; +setidentifier(); +exit; +sub setidentifier ( $href = {} ) { say 'hi'; } #2........... }, - 'rt94338.def' => { - source => "rt94338", + 'rt106492.def' => { + source => "rt106492", params => "def", expect => <<'#3...........', -# for-loop in a parenthesized block-map triggered an error message -map( { - foreach my $item ( '0', '1' ) { - print $item; - } -} qw(a b c) ); +my $ct = Courriel::Header::ContentType->new( + mime_type => 'multipart/alternative', + attributes => { boundary => unique_boundary }, +); #3........... }, - 'rt96101.def' => { - source => "rt96101", + 'rt107832.def' => { + source => "rt107832", params => "def", expect => <<'#4...........', -# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine -# references inside subroutine execution. - -# closing brace of second sub should get outdented here -sub startup { - my $self = shift; - $self->plugin( - 'authentication' => { - 'autoload_user' => 1, - 'session_key' => rand(), - 'load_user' => sub { - return HaloVP::Users->load(@_); - }, - 'validate_user' => sub { - return HaloVP::Users->login(@_); - } - } - ); -} - +my %temp = ( + supsup => 123, + nested => { + asdf => 456, + yarg => 'yarp', + }, +); #4........... }, - 'scl.def' => { - source => "scl", - params => "def", + 'rt107832.rt107832' => { + source => "rt107832", + params => "rt107832", expect => <<'#5...........', - # 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"; +my %temp = ( + supsup => 123, + nested => { + asdf => 456, + yarg => 'yarp', + }, +); #5........... }, - 'scl.scl' => { - source => "scl", - params => "scl", + 'rt111519.def' => { + source => "rt111519", + params => "def", expect => <<'#6...........', - # 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"; +use strict; +use warnings; +my $x = 1; # comment not removed + +# comment will be removed +my $y = 2; # comment also not removed #6........... }, - 'semicolon2.def' => { - source => "semicolon2", - params => "def", + 'rt111519.rt111519' => { + source => "rt111519", + params => "rt111519", expect => <<'#7...........', - # will not add semicolon for this block type - $highest = List::Util::reduce { - Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b - } +use strict; +use warnings; +my $x = 1; +my $y = 2; #7........... }, - 'side_comments1.def' => { - source => "side_comments1", + 'rt112534.def' => { + source => "rt112534", params => "def", expect => <<'#8...........', - # 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 +get( + on_ready => sub ($worker) { $on_ready->end; return; }, + on_exit => sub ( $worker, $status ) { + return; + }, + on_data => sub ($data) { $self->_on_data(@_) if $self; return; } +); #8........... }, - 'sil1.def' => { - source => "sil1", + 'rt113689.def' => { + source => "rt113689", params => "def", expect => <<'#9...........', -############################################################# - # 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; - +$a = sub { + if ( !defined( $_[0] ) ) { + print("Hello, World\n"); + } + else { print( $_[0], "\n" ); } +}; #9........... }, - 'sil1.sil' => { - source => "sil1", - params => "sil", + 'rt113689.rt113689' => { + source => "rt113689", + params => "rt113689", expect => <<'#10...........', -############################################################# -# This will walk to the left because of bad -sil guess -SKIP: { -############################################################# -} +$a = sub { + + + if ( !defined( $_[0] ) ) { -# 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; + print("Hello, World\n"); + } + else { print( $_[0], "\n" ); } + +}; #10........... }, - 'slashslash.def' => { - source => "slashslash", + 'rt113792.def' => { + source => "rt113792", params => "def", expect => <<'#11...........', -$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' =~ //; +print "hello world\n"; +__DATA__ +=> 1/2 : 0.5 #11........... }, - 'smart.def' => { - source => "smart", + 'rt114359.def' => { + source => "rt114359", params => "def", expect => <<'#12...........', -\&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; +my $x = 2; +print $x **0.5; #12........... }, - 'space1.def' => { - source => "space1", + 'rt114909.def' => { + source => "rt114909", params => "def", expect => <<'#13...........', - # We usually want a space at '} (', for example: - map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s ); +#!perl +use strict; +use warnings; + +use experimental 'signatures'; + +sub reader ( $line_sep, $chomp ) { + return sub ( $fh, $out ) : prototype(*$) { + local $/ = $line_sep; + my $content = <$fh>; + return undef unless defined $content; + chomp $content if $chomp; + $$out .= $content; + return 1; + }; +} - # But not others: - &{ $_->[1] }( delete $_[$#_]{ $_->[0] } ); +BEGIN { + *get_line = reader( "\n", 1 ); +} - # remove unwanted spaces after $ and -> here - &{ $_->[1] }( delete $_[$#_]{ $_->[0] } ); +while ( get_line( STDIN, \my $buf ) ) { + print "Got: $buf\n"; +} #13........... }, - 'space2.def' => { - source => "space2", + 'rt116344.def' => { + source => "rt116344", params => "def", expect => <<'#14...........', -# space before this opening paren -for $i ( 0 .. 20 ) { } - -# retain any space between '-' and bare word -$myhash{ USER-NAME } = 'steve'; +# Rt116344 +# Attempting to tidy the following code failed: +sub broken { + return ref {} ? 1 : 0; + something(); +} #14........... }, - 'space3.def' => { - source => "space3", + 'rt119140.def' => { + source => "rt119140", params => "def", expect => <<'#15...........', -# Treat newline as a whitespace. Otherwise, we might combine -# 'Send' and '-recipients' here -my $msg = new Fax::Send - -recipients => $to, - -data => $data; +while ( <<>> ) { } #15........... }, - 'space4.def' => { - source => "space4", + 'rt119588.def' => { + source => "rt119588", params => "def", expect => <<'#16...........', -# 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/'); +sub demo { + my $self = shift; + my $longname = shift // "xyz"; +} #16........... }, - 'space5.def' => { - source => "space5", + 'rt119970.def' => { + source => "rt119970", params => "def", expect => <<'#17...........', -# first prototype line commented out; space after 'redirect' remains -#sub html::redirect($); #<-- temporary prototype; -use html; -print html::redirect ('http://www.glob.com.au/'); - +my $x = [ + { + fooxx => 1, + bar => 1, + } +]; #17........... }, - 'structure1.def' => { - source => "structure1", - params => "def", + 'rt119970.rt119970' => { + source => "rt119970", + params => "rt119970", expect => <<'#18...........', -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?" - ) - ) - ) - ); +my $x = [ { + fooxx => 1, + bar => 1, +} ]; #18........... }, - 'style.def' => { - source => "style", + 'rt123492.def' => { + source => "rt123492", params => "def", 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 - } - } +if (1) { + print <<~EOF; + Hello there + EOF } - #19........... }, - 'style.style1' => { - source => "style", - params => "style1", + 'rt123749.def' => { + source => "rt123749", + params => "def", 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; +get('http://mojolicious.org')->then( + sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); } - if ($width <= $top->width) { - $w->grid( - -row => 0, - -column => $col, - -sticky => 'nsew' - ); # XXX +)->then( + sub { + my $cpan = shift; + say $cpan->res->code; } - } -} - +)->catch( + sub { + my $err = shift; + warn "Something went wrong: $err"; + } +)->wait; #20........... }, }; diff --git a/t/snippets8.t b/t/snippets8.t index 9eff6134..eb3d6cea 100644 --- a/t/snippets8.t +++ b/t/snippets8.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:23 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -18,77 +18,18 @@ BEGIN { # SECTION 1: Parameter combinations # ##################################### $rparams = { - 'def' => "", - 'style2' => <<'----------', --bt=2 --nwls=".." --nwrs=".." --pt=2 --nsfs --sbt=2 --cuddled-blocks --bar --nsbl --nbbc + 'def' => "", + 'rt123749' => "-wn", + 'rt124354' => "-io", + 'rt125012' => <<'----------', +-mangle +-dac ---------- - 'style3' => <<'----------', --l=160 --cbi=1 --cpi=1 --csbi=1 --lp --nolq --csci=20 --csct=40 --csc --isbc --cuddled-blocks --nsbl --dcsc + 'rt125506' => "-io", + 'rt50702' => <<'----------', +-wbb='=' ---------- - '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 ----------- - 'tso' => "-tso", + 'rt70747' => "-i=2", }; ###################### @@ -96,178 +37,130 @@ BEGIN { ###################### $rsources = { - '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 - } + 'rt123749' => <<'----------', +get('http://mojolicious.org')->then( + sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); } -} - +)->then( + sub { + my $cpan = shift; + say $cpan->res->code; + } +)->catch( + sub { + my $err = shift; + warn "Something went wrong: $err"; + } +)->wait; ---------- - 'sub1' => <<'----------', -my::doit(); -join::doit(); -for::doit(); -sub::doit(); -package::doit(); -__END__::doit(); -__DATA__::doit(); -package my; -sub doit{print"Hello My\n";}package join; -sub doit{print"Hello Join\n";}package for; -sub doit{print"Hello for\n";}package package; -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";} + 'rt123774' => <<'----------', +# retain any space between backslash and quote to avoid fooling html formatters +my $var1 = \ "bubba"; +my $var2 = \"bubba"; +my $var3 = \ 'bubba'; +my $var4 = \'bubba'; +my $var5 = \ "bubba"; ---------- - '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->(); + 'rt124114' => <<'----------', +#!/usr/bin/perl +my %h = { + a => 2 > 3 ? 1 : 0, + bbbb => sub { my $y = "1" }, + c => sub { my $z = "2" }, + d => 2 > 3 ? 1 : 0, +}; ---------- - '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' } } - } ----------- + 'rt124354' => <<'----------', +package Foo; + +use Moose; + +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); - 'syntax1' => <<'----------', -# Caused trouble: -print $x **2; +__PACKAGE__->meta->make_immutable; ---------- - 'syntax2' => <<'----------', -# ? was taken as pattern -my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; + 'rt125012' => <<'----------', +++$_ for +#one space before eol: +values %_; +system +#one space before eol: +qq{}; ---------- - 'ternary1' => <<'----------', -my $flags = - ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE : - ( $_ & 4 ) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; + 'rt125506' => <<'----------', +my $t = ' + un + deux + trois + '; ---------- - 'ternary2' => <<'----------', -my $a=($b) ? ($c) ? ($d) ? $d1 - : $d2 - : ($e) ? $e1 - : $e2 - : ($f) ? ($g) ? $g1 - : $g2 - : ($h) ? $h1 - : $h2; + '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 ); ---------- - 'tick1' => <<'----------', -sub a'this { $p'u'a = "mooo\n"; print $p::u::a; } -a::this(); # print "mooo" -print $p'u'a; # print "mooo" -sub a::that { - $p't'u = "wwoo\n"; - return sub { print $p't'u} + 'rt27000' => <<'----------', +print add( 3, 4 ), "\n"; +print add( 4, 3 ), "\n"; + +sub add { + my ( $term1, $term2 ) = @_; +# line 1234 + die "$term1 > $term2" if $term1 > $term2; + return $term1 + $term2; } -$a'that = a'that(); -$a'that->(); # print "wwoo" -$a'that = a'that(); -$p::t::u = "booo\n"; -$a'that->(); # print "booo" ---------- - 'trim_quote' => <<'----------', -# space after quote will get trimmed - push @m, ' -all :: pure_all manifypods - ' . $self->{NOECHO} . '$(NOOP) -' - unless $self->{SKIPHASH}{'all'}; + 'rt31741' => <<'----------', +$msg //= 'World'; ---------- - 'tso1' => <<'----------', -print 0+ '42 EUR'; # 42 + 'rt49289' => <<'----------', +use constant qw{ DEBUG 0 }; ---------- - 'tutor' => <<'----------', -#!/usr/bin/perl -$y=shift||5;for $i(1..10){$l[$i]="T";$w[$i]=999999;}while(1){print"Name:";$u=;$t=50;$a=time;for(0..9){$x="";for(1..$y){$x.=chr(int(rand(126-33)+33));}while($z ne $x){print"\r\n$x\r\n";$z=;chomp($z);$t-=5;}}$b=time;$t-=($b-$a)*2;$t=0-$t;$z=1;@q=@l;@p=@w;print "You scored $t points\r\nTopTen\r\n";for $i(1..10){if ($t<$p[$z]){$l[$i]=$u;chomp($l[$i]);$w[$i]=$t;$t=1000000}else{$l[$i]=$q[$z];$w[$i]=$p[$z];$z++;}print $l[$i],"\t",$w[$i],"\r\n";}} + 'rt50702' => <<'----------', +if (1) { my $uid = $ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'; } if (2) { my $uid = ($ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'); } ---------- - 'undoci1' => <<'----------', - $rinfo{deleteStyle} = [ - -fill => 'red', - -stipple => '@' . Tk->findINC('demos/images/grey.25'), - ]; + 'rt68870' => <<'----------', +s///r; ---------- - 'use1' => <<'----------', -# previously this caused an incorrect error message after '2.42' -use lib "$Common::global::gInstallRoot/lib"; -use CGI 2.42 qw(fatalsToBrowser); -use RRDs 1.000101; - -# the 0666 must expect an operator -use constant MODE => do { 0666 & ( 0777 & ~umask ) }; - -use IO::File (); + 'rt70747' => <<'----------', +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g; + } @$_; + ] +}; ---------- - 'use2' => <<'----------', -# 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); + 'rt74856' => <<'----------', +{ +my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> +my $baz = 'something else'; +} ---------- - 'version1' => <<'----------', -# VERSION statement unbroken, no semicolon added; -our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r } + 'rt78156' => <<'----------', +package Some::Class 2.012; ---------- }; @@ -276,464 +169,278 @@ our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%0 ############################## $rtests = { - 'style.style2' => { - source => "style", - params => "style2", + 'rt123749.rt123749' => { + source => "rt123749", + params => "rt123749", expect => <<'#1...........', -# 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 - } - } -} - +get('http://mojolicious.org')->then( sub { + my $mojo = shift; + say $mojo->res->code; + return get('http://metacpan.org'); +} )->then( sub { + my $cpan = shift; + say $cpan->res->code; +} )->catch( sub { + my $err = shift; + warn "Something went wrong: $err"; +} )->wait; #1........... }, - 'style.style3' => { - source => "style", - params => "style3", + 'rt123774.def' => { + source => "rt123774", + params => "def", expect => <<'#2...........', -# 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 - +# retain any space between backslash and quote to avoid fooling html formatters +my $var1 = \ "bubba"; +my $var2 = \"bubba"; +my $var3 = \ 'bubba'; +my $var4 = \'bubba'; +my $var5 = \ "bubba"; #2........... }, - 'style.style4' => { - source => "style", - params => "style4", + 'rt124114.def' => { + source => "rt124114", + params => "def", expect => <<'#3...........', -# 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 - } - } -} - +#!/usr/bin/perl +my %h = { + a => 2 > 3 ? 1 : 0, + bbbb => sub { my $y = "1" }, + c => sub { my $z = "2" }, + d => 2 > 3 ? 1 : 0, +}; #3........... }, - 'style.style5' => { - source => "style", - params => "style5", + 'rt124354.def' => { + source => "rt124354", + params => "def", expect => <<'#4...........', -# 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 - } - } -} +package Foo; + +use Moose; +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); + +__PACKAGE__->meta->make_immutable; #4........... }, - 'sub1.def' => { - source => "sub1", - params => "def", + 'rt124354.rt124354' => { + source => "rt124354", + params => "rt124354", expect => <<'#5...........', -my::doit(); -join::doit(); -for::doit(); -sub::doit(); -package::doit(); -__END__::doit(); -__DATA__::doit(); - -package my; -sub doit { print "Hello My\n"; } - -package join; -sub doit { print "Hello Join\n"; } +package Foo; -package for; -sub doit { print "Hello for\n"; } +use Moose; -package package; -sub doit { print "Hello package\n"; } +has a => ( is => 'ro', isa => 'Int' ); +has b => ( is => 'ro', isa => 'Int' ); +has c => ( is => 'ro', isa => 'Int' ); -package sub; -sub doit { print "Hello sub\n"; } - -package __END__; -sub doit { print "Hello __END__\n"; } - -package __DATA__; -sub doit { print "Hello __DATA__\n"; } +__PACKAGE__->meta->make_immutable; #5........... }, - 'sub2.def' => { - source => "sub2", + 'rt125012.def' => { + source => "rt125012", params => "def", expect => <<'#6...........', -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->(); +++$_ for + + #one space before eol: + values %_; +system + + #one space before eol: + qq{}; #6........... }, - 'switch1.def' => { - source => "switch1", - params => "def", + 'rt125012.rt125012' => { + source => "rt125012", + params => "rt125012", expect => <<'#7...........', -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' } - } -} +++$_ for values%_; +system qq{}; #7........... }, - 'syntax1.def' => { - source => "syntax1", + 'rt125506.def' => { + source => "rt125506", params => "def", expect => <<'#8...........', -# Caused trouble: -print $x **2; +my $t = ' + un + deux + trois + '; #8........... }, - 'syntax2.def' => { - source => "syntax2", - params => "def", + 'rt125506.rt125506' => { + source => "rt125506", + params => "rt125506", expect => <<'#9...........', -# ? was taken as pattern -my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; +my $t = ' + un + deux + trois + '; #9........... }, - 'ternary1.def' => { - source => "ternary1", + 'rt15735.def' => { + source => "rt15735", params => "def", expect => <<'#10...........', -my $flags = - ( $_ & 1 ) - ? ( $_ & 4 ) - ? $THRf_DEAD - : $THRf_ZOMBIE - : ( $_ & 4 ) ? $THRf_R_DETACHED - : $THRf_R_JOINABLE; +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); #10........... }, - 'ternary2.def' => { - source => "ternary2", + 'rt27000.def' => { + source => "rt27000", params => "def", expect => <<'#11...........', -my $a = - ($b) - ? ($c) - ? ($d) - ? $d1 - : $d2 - : ($e) ? $e1 - : $e2 - : ($f) ? ($g) - ? $g1 - : $g2 - : ($h) ? $h1 - : $h2; +print add( 3, 4 ), "\n"; +print add( 4, 3 ), "\n"; + +sub add { + my ( $term1, $term2 ) = @_; +# line 1234 + die "$term1 > $term2" if $term1 > $term2; + return $term1 + $term2; +} #11........... }, - 'tick1.def' => { - source => "tick1", + 'rt31741.def' => { + source => "rt31741", params => "def", expect => <<'#12...........', -sub a'this { $p'u'a = "mooo\n"; print $p::u::a; } -a::this(); # print "mooo" -print $p'u'a; # print "mooo" - -sub a::that { - $p't'u = "wwoo\n"; - return sub { print $p't'u} -} -$a'that = a'that(); -$a'that->(); # print "wwoo" -$a'that = a'that(); -$p::t::u = "booo\n"; -$a'that->(); # print "booo" +$msg //= 'World'; #12........... }, - 'trim_quote.def' => { - source => "trim_quote", + 'rt49289.def' => { + source => "rt49289", params => "def", expect => <<'#13...........', - # space after quote will get trimmed - push @m, ' -all :: pure_all manifypods - ' . $self->{NOECHO} . '$(NOOP) -' - unless $self->{SKIPHASH}{'all'}; +use constant qw{ DEBUG 0 }; #13........... }, - 'tso1.def' => { - source => "tso1", + 'rt50702.def' => { + source => "rt50702", params => "def", expect => <<'#14...........', -print 0 + '42 EUR'; # 42 +if (1) { + my $uid = + $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar'; +} +if (2) { + my $uid = + ( $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar' ); +} #14........... }, - 'tso1.tso' => { - source => "tso1", - params => "tso", + 'rt50702.rt50702' => { + source => "rt50702", + params => "rt50702", expect => <<'#15...........', -print 0+ '42 EUR'; # 42 +if (1) { + my $uid + = $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar'; +} +if (2) { + my $uid + = ( $ENV{'ORIG_LOGNAME'} + || $ENV{'LOGNAME'} + || $ENV{'REMOTE_USER'} + || 'foobar' ); +} #15........... }, - 'tutor.def' => { - source => "tutor", + 'rt68870.def' => { + source => "rt68870", params => "def", expect => <<'#16...........', -#!/usr/bin/perl -$y = shift || 5; -for $i ( 1 .. 10 ) { $l[$i] = "T"; $w[$i] = 999999; } -while (1) { - print "Name:"; - $u = ; - $t = 50; - $a = time; - for ( 0 .. 9 ) { - $x = ""; - for ( 1 .. $y ) { $x .= chr( int( rand( 126 - 33 ) + 33 ) ); } - while ( $z ne $x ) { - print "\r\n$x\r\n"; - $z = ; - chomp($z); - $t -= 5; - } - } - $b = time; - $t -= ( $b - $a ) * 2; - $t = 0 - $t; - $z = 1; - @q = @l; - @p = @w; - print "You scored $t points\r\nTopTen\r\n"; - - for $i ( 1 .. 10 ) { - if ( $t < $p[$z] ) { - $l[$i] = $u; - chomp( $l[$i] ); - $w[$i] = $t; - $t = 1000000; - } - else { $l[$i] = $q[$z]; $w[$i] = $p[$z]; $z++; } - print $l[$i], "\t", $w[$i], "\r\n"; - } -} +s///r; #16........... }, - 'undoci1.def' => { - source => "undoci1", + 'rt70747.def' => { + source => "rt70747", params => "def", expect => <<'#17...........', - $rinfo{deleteStyle} = [ - -fill => 'red', - -stipple => '@' . Tk->findINC('demos/images/grey.25'), - ]; +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ + map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; + $g; + } @$_; + ] +}; #17........... }, - 'use1.def' => { - source => "use1", - params => "def", + 'rt70747.rt70747' => { + source => "rt70747", + params => "rt70747", expect => <<'#18...........', -# previously this caused an incorrect error message after '2.42' -use lib "$Common::global::gInstallRoot/lib"; -use CGI 2.42 qw(fatalsToBrowser); -use RRDs 1.000101; - -# the 0666 must expect an operator -use constant MODE => do { 0666 & ( 0777 & ~umask ) }; - -use IO::File (); +coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via { + [ + map { + my $g = $_->as_hash; + $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; + $g; + } @$_; + ] +}; #18........... }, - 'use2.def' => { - source => "use2", + 'rt74856.def' => { + source => "rt74856", params => "def", expect => <<'#19...........', -# 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); +{ + my $foo = '1'; +#<<< +my $bar = (test()) + ? 'some value' + : undef; +#>>> + my $baz = 'something else'; +} #19........... }, - 'version1.def' => { - source => "version1", + 'rt78156.def' => { + source => "rt78156", params => "def", expect => <<'#20...........', -# VERSION statement unbroken, no semicolon added; -our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r } +package Some::Class 2.012; #20........... }, }; diff --git a/t/snippets9.t b/t/snippets9.t index 0e38b94b..deb0b908 100644 --- a/t/snippets9.t +++ b/t/snippets9.t @@ -1,6 +1,6 @@ # **This script was automatically generated** # Created with: ./make_t.pl -# Thu Apr 5 07:31:24 2018 +# Tue Jun 12 19:09:24 2018 # To locate test #13 for example, search for the string '#13' @@ -18,20 +18,13 @@ BEGIN { # SECTION 1: Parameter combinations # ##################################### $rparams = { - 'def' => "", - 'vmll' => <<'----------', --vmll --bbt=2 --bt=2 --pt=2 --sbt=2 + 'def' => "", + 'rt81852' => <<'----------', +-wn +-act=2 ---------- - 'vtc' => <<'----------', --sbvtc=2 --bvtc=2 --pvtc=2 ----------- - 'wn' => "-wn", + 'rt98902' => "-boc", + 'scl' => "-scl=12", }; ###################### @@ -39,116 +32,135 @@ BEGIN { ###################### $rsources = { - 'version2' => <<'----------', -# On one line so MakeMaker will see it. -require Exporter; our $VERSION = $Exporter::VERSION; + 'rt78764' => <<'----------', +qr/3/ ~~ ['1234'] ? 1 : 0; +map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; ---------- - 'vert' => <<'----------', -# if $w->vert is tokenized as type 'U' then the ? will start a quote -# and an error will occur. -sub vert { -} -sub Restore { - $w->vert ? $w->delta_width(0) : $w->delta_height(0); + 'rt79813' => <<'----------', +my %hash = ( a => { bbbbbbbbb => { + cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx', + }, },); +---------- + + 'rt79947' => <<'----------', +try { croak "An Error!"; } +catch ($error) { + print STDERR $error . "\n"; } ---------- - 'vmll' => <<'----------', - # 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))} + 'rt80645' => <<'----------', +BEGIN { $^W = 1; } +use warnings; +use strict; +@$ = 'test'; +print $#{$}; +---------- - This has the comma on the next line - exception {Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)}, + 'rt81852' => <<'----------', +do { + { + next if ( $n % 2 ); + print $n, "\n"; + } +} while ( $n++ < 10 ); ---------- - '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], - ); + 'rt81854' => <<'----------', +return "this is a descriptive error message" + if $res->is_error or not length $data; ---------- - 'vtc2' => <<'----------', - ok( - $s->call( - SOAP::Data->name('getStateName') - ->attr( { xmlns => 'urn:/My/Examples' } ), - 1 - )->result eq 'Alabama' - ); + 'rt87502' => <<'----------', +if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) { + # CODE +} ---------- - 'vtc3' => <<'----------', - $day_long = ( - "Sunday", "Monday", "Tuesday", "Wednesday", - "Thursday", "Friday", "Saturday", "Sunday" - )[$wday]; + 'rt93197' => <<'----------', +$to = $to->{$_} ||= {} for @key; if (1) {2;} else {3;} ---------- - 'vtc4' => <<'----------', -my$bg_color=$im->colorAllocate(unpack('C3',pack('H2H2H2',unpack('a2a2a2',(length($options_r->{'bg_color'})?$options_r->{'bg_color'}:$MIDI::Opus::BG_color))))); + 'rt94338' => <<'----------', +# for-loop in a parenthesized block-map triggered an error message +map( { foreach my $item ( '0', '1' ) { print $item} } qw(a b c) ); ---------- - 'wn1' => <<'----------', - my $bg_color = $im->colorAllocate( - unpack( - 'C3', - pack( - 'H2H2H2', - unpack( - 'a2a2a2', - ( - length( $options_r->{'bg_color'} ) - ? $options_r->{'bg_color'} - : $MIDI::Opus::BG_color - ) - ) - ) - ) - ); + 'rt95419' => <<'----------', +case "blah" => sub { + { a => 1 } +}; +---------- + + 'rt95708' => <<'----------', +use strict; +use JSON; +my $ref = { +when => time(), message => 'abc' }; +my $json = encode_json { +when => time(), message => 'abc' }; +my $json2 = encode_json + { +when => time(), message => 'abc' }; +---------- + + 'rt96021' => <<'----------', +$a->@*; +$a->**; +$a->$*; +$a->&*; +$a->%*; +$a->$#* ---------- - 'wn2' => <<'----------', -if ($PLATFORM eq 'aix') { - skip_symbols([qw( - Perl_dump_fds - Perl_ErrorNo - Perl_GetVars - PL_sys_intern - )]); + 'rt96101' => <<'----------', +# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine +# references inside subroutine execution. + +# closing brace of second sub should get outdented here +sub startup { + my $self = shift; + $self->plugin( + 'authentication' => { + 'autoload_user' => 1, + 'session_key' => rand(), + 'load_user' => sub { + return HaloVP::Users->load(@_); + }, + 'validate_user' => sub { + return HaloVP::Users->login(@_); + } + } + ); } + ---------- - 'wn3' => <<'----------', -deferred->resolve->then( - sub { - push @out, 'Resolve'; - return $then; - } -)->then( - sub { - push @out, 'Reject'; - push @out, @_; - } + 'rt98902' => <<'----------', +my %foo = ( + alpha => 1, +beta => 2, gamma => 3, ); + +my @bar = map { { +number => $_, +character => chr $_, +padding => ( ' ' x $_ ), +} } ( 0 .. 32 ); +---------- + + 'rt99961' => <<'----------', +%thing = %{ print qq[blah1\n]; $b; }; +---------- + + '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"; ---------- - 'wn4' => <<'----------', -{{{ - # Orignal formatting looks nice but would be hard to duplicate - return exists $G->{ Attr }->{ E } && - exists $G->{ Attr }->{ E }->{ $u } && - exists $G->{ Attr }->{ E }->{ $u }->{ $v } ? - %{ $G->{ Attr }->{ E }->{ $u }->{ $v } } : - ( ); -}}} + 'semicolon2' => <<'----------', + # will not add semicolon for this block type + $highest = List::Util::reduce { Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b } ---------- }; @@ -157,327 +169,273 @@ deferred->resolve->then( ############################## $rtests = { - 'version2.def' => { - source => "version2", + 'rt78764.def' => { + source => "rt78764", params => "def", expect => <<'#1...........', -# On one line so MakeMaker will see it. -require Exporter; our $VERSION = $Exporter::VERSION; +qr/3/ ~~ ['1234'] ? 1 : 0; +map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a; #1........... }, - 'vert.def' => { - source => "vert", + 'rt79813.def' => { + source => "rt79813", params => "def", expect => <<'#2...........', -# if $w->vert is tokenized as type 'U' then the ? will start a quote -# and an error will occur. -sub vert { -} - -sub Restore { - $w->vert ? $w->delta_width(0) : $w->delta_height(0); -} +my %hash = ( + a => { + bbbbbbbbb => { + cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx', + }, + }, +); #2........... }, - 'vmll.def' => { - source => "vmll", + 'rt79947.def' => { + source => "rt79947", params => "def", expect => <<'#3...........', - # 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 ) ); - } - - This has the comma on the next line exception { - Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) - }, +try { croak "An Error!"; } +catch ($error) { + print STDERR $error . "\n"; +} #3........... }, - 'vmll.vmll' => { - source => "vmll", - params => "vmll", + 'rt80645.def' => { + source => "rt80645", + params => "def", expect => <<'#4...........', - # 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))} - - This has the comma on the next line exception { - Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) - }, +BEGIN { $^W = 1; } +use warnings; +use strict; +@$ = 'test'; +print $#{$}; #4........... }, - 'vtc1.def' => { - source => "vtc1", + 'rt81852.def' => { + source => "rt81852", params => "def", expect => <<'#5...........', -@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 - ], -); +do { + { + next if ( $n % 2 ); + print $n, "\n"; + } +} while ( $n++ < 10 ); #5........... }, - 'vtc1.vtc' => { - source => "vtc1", - params => "vtc", + 'rt81852.rt81852' => { + source => "rt81852", + params => "rt81852", expect => <<'#6...........', -@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 ], ); +do {{ + next if ($n % 2); + print $n, "\n"; +}} while ($n++ < 10); #6........... }, - 'vtc2.def' => { - source => "vtc2", + 'rt81854.def' => { + source => "rt81854", params => "def", expect => <<'#7...........', - ok( - $s->call( - SOAP::Data->name('getStateName') - ->attr( { xmlns => 'urn:/My/Examples' } ), - 1 - )->result eq 'Alabama' - ); +return "this is a descriptive error message" + if $res->is_error or not length $data; #7........... }, - 'vtc2.vtc' => { - source => "vtc2", - params => "vtc", + 'rt87502.def' => { + source => "rt87502", + params => "def", expect => <<'#8...........', - ok( - $s->call( - SOAP::Data->name('getStateName') - ->attr( { xmlns => 'urn:/My/Examples' } ), - 1 )->result eq 'Alabama' ); +if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) { + + # CODE +} #8........... }, - 'vtc3.def' => { - source => "vtc3", + 'rt93197.def' => { + source => "rt93197", params => "def", expect => <<'#9...........', - $day_long = ( - "Sunday", "Monday", "Tuesday", "Wednesday", - "Thursday", "Friday", "Saturday", "Sunday" - )[$wday]; +$to = $to->{$_} ||= {} for @key; +if (1) { 2; } +else { 3; } #9........... }, - 'vtc3.vtc' => { - source => "vtc3", - params => "vtc", + 'rt94338.def' => { + source => "rt94338", + params => "def", expect => <<'#10...........', - $day_long = ( - "Sunday", "Monday", "Tuesday", "Wednesday", - "Thursday", "Friday", "Saturday", "Sunday" )[$wday]; +# for-loop in a parenthesized block-map triggered an error message +map( { + foreach my $item ( '0', '1' ) { + print $item; + } +} qw(a b c) ); #10........... }, - 'vtc4.def' => { - source => "vtc4", + 'rt95419.def' => { + source => "rt95419", params => "def", expect => <<'#11...........', -my $bg_color = $im->colorAllocate( - unpack( - 'C3', - pack( - 'H2H2H2', - unpack( - 'a2a2a2', - ( - length( $options_r->{'bg_color'} ) - ? $options_r->{'bg_color'} - : $MIDI::Opus::BG_color - ) - ) - ) - ) -); +case "blah" => sub { + { a => 1 } +}; #11........... }, - 'vtc4.vtc' => { - source => "vtc4", - params => "vtc", + 'rt95708.def' => { + source => "rt95708", + params => "def", expect => <<'#12...........', -my $bg_color = $im->colorAllocate( - unpack( - 'C3', - pack( - 'H2H2H2', - unpack( - 'a2a2a2', - ( - length( $options_r->{'bg_color'} ) - ? $options_r->{'bg_color'} - : $MIDI::Opus::BG_color ) ) ) ) ); +use strict; +use JSON; +my $ref = { + when => time(), + message => 'abc' +}; +my $json = encode_json { + when => time(), + message => 'abc' +}; +my $json2 = encode_json + { + when => time(), + message => 'abc' +}; #12........... }, - 'wn1.def' => { - source => "wn1", + 'rt96021.def' => { + source => "rt96021", params => "def", expect => <<'#13...........', - my $bg_color = $im->colorAllocate( - unpack( - 'C3', - pack( - 'H2H2H2', - unpack( - 'a2a2a2', - ( - length( $options_r->{'bg_color'} ) - ? $options_r->{'bg_color'} - : $MIDI::Opus::BG_color - ) - ) - ) - ) - ); +$a->@*; +$a->**; +$a->$*; +$a->&*; +$a->%*; +$a->$#* #13........... }, - 'wn1.wn' => { - source => "wn1", - params => "wn", + 'rt96101.def' => { + source => "rt96101", + params => "def", expect => <<'#14...........', - my $bg_color = $im->colorAllocate( unpack( - 'C3', - pack( - 'H2H2H2', - unpack( - 'a2a2a2', - ( - length( $options_r->{'bg_color'} ) - ? $options_r->{'bg_color'} - : $MIDI::Opus::BG_color - ) - ) - ) - ) ); +# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine +# references inside subroutine execution. + +# closing brace of second sub should get outdented here +sub startup { + my $self = shift; + $self->plugin( + 'authentication' => { + 'autoload_user' => 1, + 'session_key' => rand(), + 'load_user' => sub { + return HaloVP::Users->load(@_); + }, + 'validate_user' => sub { + return HaloVP::Users->login(@_); + } + } + ); +} + #14........... }, - 'wn2.def' => { - source => "wn2", + 'rt98902.def' => { + source => "rt98902", params => "def", expect => <<'#15...........', -if ( $PLATFORM eq 'aix' ) { - skip_symbols( - [ - qw( - Perl_dump_fds - Perl_ErrorNo - Perl_GetVars - PL_sys_intern - ) - ] - ); -} +my %foo = ( + alpha => 1, + beta => 2, + gamma => 3, +); + +my @bar = + map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } } + ( 0 .. 32 ); #15........... }, - 'wn2.wn' => { - source => "wn2", - params => "wn", + 'rt98902.rt98902' => { + source => "rt98902", + params => "rt98902", expect => <<'#16...........', -if ( $PLATFORM eq 'aix' ) { - skip_symbols( [ qw( - Perl_dump_fds - Perl_ErrorNo - Perl_GetVars - PL_sys_intern - ) ] ); -} +my %foo = ( + alpha => 1, + beta => 2, gamma => 3, +); + +my @bar = map { + { + number => $_, + character => chr $_, + padding => ( ' ' x $_ ), + } +} ( 0 .. 32 ); #16........... }, - 'wn3.def' => { - source => "wn3", + 'rt99961.def' => { + source => "rt99961", params => "def", expect => <<'#17...........', -deferred->resolve->then( - sub { - push @out, 'Resolve'; - return $then; - } -)->then( - sub { - push @out, 'Reject'; - push @out, @_; - } -); +%thing = %{ + print qq[blah1\n]; + $b; +}; #17........... }, - 'wn3.wn' => { - source => "wn3", - params => "wn", + 'scl.def' => { + source => "scl", + params => "def", expect => <<'#18...........', -deferred->resolve->then( sub { - push @out, 'Resolve'; - return $then; -} )->then( sub { - push @out, 'Reject'; - push @out, @_; -} ); + # 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"; #18........... }, - 'wn4.def' => { - source => "wn4", - params => "def", + 'scl.scl' => { + source => "scl", + params => "scl", expect => <<'#19...........', -{ - { - { - # Orignal formatting looks nice but would be hard to duplicate - return - exists $G->{Attr}->{E} - && exists $G->{Attr}->{E}->{$u} - && exists $G->{Attr}->{E}->{$u}->{$v} - ? %{ $G->{Attr}->{E}->{$u}->{$v} } - : (); - } - } -} + # 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........... }, - 'wn4.wn' => { - source => "wn4", - params => "wn", + 'semicolon2.def' => { + source => "semicolon2", + params => "def", expect => <<'#20...........', -{ { { - - # Orignal formatting looks nice but would be hard to duplicate - return - exists $G->{Attr}->{E} - && exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v} - ? %{ $G->{Attr}->{E}->{$u}->{$v} } - : (); -} } } + # will not add semicolon for this block type + $highest = List::Util::reduce { + Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b + } #20........... }, };