--- /dev/null
+switch (1) {
+ case x { 2 } else { }
+}
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.
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
# 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
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
$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
],
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,
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
+ ]
};
--- /dev/null
+switch (1) {
+ case x { 2 } else { }
+}
--- /dev/null
+{ source_host => MM::Config->instance->host // q{}, }
--- /dev/null
+state $b //= ccc();
--- /dev/null
+#!/usr/bin/env perl
+use v5.020; #includes strict
+use warnings;
+use experimental 'signatures';
+setidentifier();
+exit;
+sub setidentifier ( $href = {} ) { say 'hi'; }
--- /dev/null
+my $ct = Courriel::Header::ContentType->new(
+ mime_type => 'multipart/alternative',
+ attributes => { boundary => unique_boundary },
+);
--- /dev/null
+my %temp = (
+ supsup => 123,
+ nested => {
+ asdf => 456,
+ yarg => 'yarp',
+ },
+);
--- /dev/null
+my %temp = (
+ supsup => 123,
+ nested => {
+ asdf => 456,
+ yarg => 'yarp',
+ },
+);
--- /dev/null
+use strict;
+use warnings;
+my $x = 1; # comment not removed
+
+# comment will be removed
+my $y = 2; # comment also not removed
--- /dev/null
+use strict;
+use warnings;
+my $x = 1;
+my $y = 2;
--- /dev/null
+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; }
+);
--- /dev/null
+$a = sub {
+ if ( !defined( $_[0] ) ) {
+ print("Hello, World\n");
+ }
+ else { print( $_[0], "\n" ); }
+};
--- /dev/null
+$a = sub {
+
+
+ if ( !defined( $_[0] ) ) {
+
+
+ print("Hello, World\n");
+
+ }
+ else { print( $_[0], "\n" ); }
+
+};
--- /dev/null
+print "hello world\n";
+__DATA__
+=> 1/2 : 0.5
--- /dev/null
+my $x = 2;
+print $x **0.5;
--- /dev/null
+#!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";
+}
--- /dev/null
+while ( <<>> ) { }
--- /dev/null
+sub demo {
+ my $self = shift;
+ my $longname = shift // "xyz";
+}
--- /dev/null
+my $x = [
+ {
+ fooxx => 1,
+ bar => 1,
+ }
+];
--- /dev/null
+my $x = [ {
+ fooxx => 1,
+ bar => 1,
+} ];
--- /dev/null
+if (1) {
+ print <<~EOF;
+ Hello there
+ EOF
+}
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+#!/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,
+};
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+my $t = '
+ un
+ deux
+ trois
+ ';
--- /dev/null
+my $t = '
+ un
+ deux
+ trois
+ ';
--- /dev/null
+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);
--- /dev/null
+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;
+}
--- /dev/null
+$msg //= 'World';
--- /dev/null
+use constant qw{ DEBUG 0 };
--- /dev/null
+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' );
+}
--- /dev/null
+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' );
+}
--- /dev/null
+coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
+ [
+ map {
+ my $g = $_->as_hash;
+ $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ];
+ $g;
+ } @$_;
+ ]
+};
--- /dev/null
+coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
+ [
+ map {
+ my $g = $_->as_hash;
+ $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ];
+ $g;
+ } @$_;
+ ]
+};
--- /dev/null
+{
+ my $foo = '1';
+#<<<
+my $bar = (test())
+ ? 'some value'
+ : undef;
+#>>>
+ my $baz = 'something else';
+}
--- /dev/null
+package Some::Class 2.012;
--- /dev/null
+qr/3/ ~~ ['1234'] ? 1 : 0;
+map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
--- /dev/null
+my %hash = (
+ a => {
+ bbbbbbbbb => {
+ cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx',
+ },
+ },
+);
--- /dev/null
+try { croak "An Error!"; }
+catch ($error) {
+ print STDERR $error . "\n";
+}
--- /dev/null
+BEGIN { $^W = 1; }
+use warnings;
+use strict;
+@$ = 'test';
+print $#{$};
--- /dev/null
+do {
+ {
+ next if ( $n % 2 );
+ print $n, "\n";
+ }
+} while ( $n++ < 10 );
--- /dev/null
+do {{
+ next if ($n % 2);
+ print $n, "\n";
+}} while ($n++ < 10);
--- /dev/null
+return "this is a descriptive error message"
+ if $res->is_error or not length $data;
--- /dev/null
+if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) {
+
+ # CODE
+}
--- /dev/null
+$to = $to->{$_} ||= {} for @key;
+if (1) { 2; }
+else { 3; }
--- /dev/null
+case "blah" => sub {
+ { a => 1 }
+};
--- /dev/null
+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'
+};
--- /dev/null
+$a->@*;
+$a->**;
+$a->$*;
+$a->&*;
+$a->%*;
+$a->$#*
--- /dev/null
+my %foo = (
+ alpha => 1,
+ beta => 2,
+ gamma => 3,
+);
+
+my @bar =
+ map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } }
+ ( 0 .. 32 );
--- /dev/null
+my %foo = (
+ alpha => 1,
+ beta => 2, gamma => 3,
+);
+
+my @bar = map {
+ {
+ number => $_,
+ character => chr $_,
+ padding => ( ' ' x $_ ),
+ }
+} ( 0 .. 32 );
--- /dev/null
+%thing = %{
+ print qq[blah1\n];
+ $b;
+};
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 ) ) {
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 <<EOM;
$diff_msg
-Enter ./$runme to move results to expect/ if results are acceptable
+Look at any new results in tmp/ and then
+Enter ./$runme to move results from tmp/ to expect/ if results are acceptable
EOM
}
foreach my $n ( $nbeg .. $nend ) { push @tests, $rtests->[$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 {
--- /dev/null
+{ source_host => MM::Config->instance->host // q{}, }
--- /dev/null
+state $b //= ccc();
--- /dev/null
+#!/usr/bin/env perl
+use v5.020; #includes strict
+use warnings;
+use experimental 'signatures';
+setidentifier();
+exit;
+sub setidentifier ( $href = {} ) { say 'hi'; }
--- /dev/null
+my $ct = Courriel::Header::ContentType->new( mime_type => 'multipart/alternative', attributes => { boundary => unique_boundary }, );
--- /dev/null
+my %temp =
+(
+supsup => 123,
+nested => {
+asdf => 456,
+yarg => 'yarp',
+}, );
--- /dev/null
+use strict;
+use warnings;
+my $x = 1; # comment not removed
+# comment will be removed
+my $y = 2; # comment also not removed
--- /dev/null
+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; } );
--- /dev/null
+$a = sub {
+ if ( !defined( $_[0] ) ) {
+ print("Hello, World\n");
+ }
+ else { print( $_[0], "\n" ); }
+};
--- /dev/null
+-blao=2
+-blbc=1
+-blaol='*'
+-blbcl='*'
--- /dev/null
+print "hello world\n";
+__DATA__
+=> 1/2 : 0.5
--- /dev/null
+my $x = 2; print $x ** 0.5;
--- /dev/null
+#!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";
+}
--- /dev/null
+while (<<>>) { }
--- /dev/null
+sub demo {
+ my $self = shift;
+ my $longname = shift // "xyz";
+}
--- /dev/null
+my $x = [
+ {
+ fooxx => 1,
+ bar => 1,
+ }
+];
--- /dev/null
+if (1) {
+ print <<~EOF;
+ Hello there
+ EOF
+}
--- /dev/null
+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;
--- /dev/null
+#!/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,
+};
--- /dev/null
+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;
--- /dev/null
+my $t = '
+ un
+ deux
+ trois
+ ';
--- /dev/null
+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 );
--- /dev/null
+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;
+}
--- /dev/null
+$msg //= 'World';
--- /dev/null
+use constant qw{ DEBUG 0 };
--- /dev/null
+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'); }
--- /dev/null
+coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
+ [ map {
+ my $g = $_->as_hash;
+ $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g;
+ } @$_;
+ ]
+};
--- /dev/null
+{
+my $foo = '1';
+#<<<
+my $bar = (test())
+ ? 'some value'
+ : undef;
+#>>>
+my $baz = 'something else';
+}
--- /dev/null
+package Some::Class 2.012;
--- /dev/null
+qr/3/ ~~ ['1234'] ? 1 : 0;
+map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
--- /dev/null
+my %hash = ( a => { bbbbbbbbb => {
+ cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx',
+ }, },);
--- /dev/null
+try { croak "An Error!"; }
+catch ($error) {
+ print STDERR $error . "\n";
+}
--- /dev/null
+BEGIN { $^W = 1; }
+use warnings;
+use strict;
+@$ = 'test';
+print $#{$};
--- /dev/null
+do {
+ {
+ next if ( $n % 2 );
+ print $n, "\n";
+ }
+} while ( $n++ < 10 );
--- /dev/null
+-wn
+-act=2
--- /dev/null
+return "this is a descriptive error message"
+ if $res->is_error or not length $data;
--- /dev/null
+if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) {
+ # CODE
+}
--- /dev/null
+$to = $to->{$_} ||= {} for @key; if (1) {2;} else {3;}
--- /dev/null
+case "blah" => sub {
+ { a => 1 }
+};
--- /dev/null
+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' };
--- /dev/null
+$a->@*;
+$a->**;
+$a->$*;
+$a->&*;
+$a->%*;
+$a->$#*
--- /dev/null
+my %foo = (
+ alpha => 1,
+beta => 2, gamma => 3,
+);
+
+my @bar = map { {
+number => $_,
+character => chr $_,
+padding => ( ' ' x $_ ),
+} } ( 0 .. 32 );
--- /dev/null
+%thing = %{ print qq[blah1\n]; $b; };
# **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'
######################
$rsources = {
+ '105484' => <<'----------',
+switch (1) {
+ case x { 2 } else { }
+}
+----------
+
'align1' => <<'----------',
return ( $fetch_key eq $fk
&& $store_key eq $sk
{
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' ) {
-}
-
----------
};
##############################
$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
{
$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 )
{
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 ) +
( $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)
{
$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
&& (
|| ( $options->{'verbose'} & 64 ) )
)
)
-#14...........
+#15...........
},
'andor5.def' => {
source => "andor5",
params => "def",
- expect => <<'#15...........',
+ expect => <<'#16...........',
# two levels of && with side comments
if (
defined &syscopy
{
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;
)
);
}
-#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' )
{
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...........
},
};
# **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'
# 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
+----------
};
######################
######################
$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' } }
+ }
----------
};
##############################
$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};
--- /dev/null
+# **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=<STDIN>;$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=<STDIN>;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 = <STDIN>;
+ $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 = <STDIN>;
+ 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 "<<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 );
+ }
+}
--- /dev/null
+# **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 "<<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 );
+ }
+}
# **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'
# 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' => "",
};
######################
$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;
}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
- )
-}
----------
};
##############################
$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;
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";
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
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,
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;
} 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;
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...........
},
};
# **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'
# SECTION 1: Parameter combinations #
#####################################
$rparams = {
+ 'ce_wn' => <<'----------',
+-cuddled-blocks
+-wn
+----------
'colin' => <<'----------',
-l=0
-pt=2
'essential2' => "-extrude",
'extrude' => "--extrude",
'fabrice_bug' => "-bt=0",
- 'gnu' => "-gnu",
};
######################
##############################
$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,
$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,
{
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
# 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
# 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
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(
)
;
}
-#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
(
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
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 =
@<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
write;
}
}
-#17...........
+#18...........
},
'given1.def' => {
source => "given1",
params => "def",
- expect => <<'#18...........',
+ expect => <<'#19...........',
given ( [ 9, "a", 11 ] ) {
when (qr/\d/) {
given ($count) {
}
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...........
},
};
# **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'
######################
$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',
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);
----------
};
##############################
$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',
'-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; '
. $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\@/'
. $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
$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",
],
},
);
-#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...........',
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<!-- Generated by perltidy -->
</pre>
</body>
</html>
-#13...........
+#14...........
},
'ident1.def' => {
source => "ident1",
params => "def",
- expect => <<'#14...........',
+ expect => <<'#15...........',
package A;
sub new {
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";
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
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...........
},
};
# **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'
'mangle' => "--mangle",
'nasc' => "-nasc",
'nothing' => "",
- 'otr' => <<'----------',
--ohbr
--opr
--osbr
-----------
};
######################
######################
$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] }
##############################
$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(
)
),
);
-#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(
)
),
);
-#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.
}
}
-#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.
# 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 $#
# 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'
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. ],
[ 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 ],
[ 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 +
$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 =
( 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 ',',
(
} @_
)
);
-#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...........
},
};
# **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'
#####################################
$rparams = {
'def' => "",
+ 'otr' => <<'----------',
+-ohbr
+-opr
+-osbr
+----------
'pbp' => "-pbp -nst -nse",
};
######################
$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 +
$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();
----------
};
##############################
$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(
}
);
-#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(
}
);
-#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",
"\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...........
},
};
# **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'
#####################################
$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",
};
######################
######################
$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;
----------
};
##############################
$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...........
},
};
# **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'
# 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",
};
######################
######################
$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=<STDIN>;$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=<STDIN>;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;
----------
};
##############################
$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 = <STDIN>;
- $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 = <STDIN>;
- 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...........
},
};
# **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'
# 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",
};
######################
######################
$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 }
----------
};
##############################
$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...........
},
};
projects / perltidy.git / commitdiff