1 # Created with: ./make_t.pl
25 # To locate test #13 you can search for its name or the string '#13'
37 ###########################################
38 # BEGIN SECTION 1: Parameter combinations #
39 ###########################################
42 'vtc' => <<'----------',
50 ############################
51 # BEGIN SECTION 2: Sources #
52 ############################
55 'vtc1' => <<'----------',
57 [ 'Dr. Watson', undef, '221b', 'Baker St.',
58 undef, 'London', 'NW1', undef,
61 [ 'Sam Gamgee', undef, undef, 'Bagshot Row',
62 undef, 'Hobbiton', undef, undef,
67 'vtc2' => <<'----------',
70 SOAP::Data->name('getStateName')
71 ->attr( { xmlns => 'urn:/My/Examples' } ),
73 )->result eq 'Alabama'
77 'vtc3' => <<'----------',
79 "Sunday", "Monday", "Tuesday", "Wednesday",
80 "Thursday", "Friday", "Saturday", "Sunday"
84 'vtc4' => <<'----------',
85 my$bg_color=$im->colorAllocate(unpack('C3',pack('H2H2H2',unpack('a2a2a2',(length($options_r->{'bg_color'})?$options_r->{'bg_color'}:$MIDI::Opus::BG_color)))));
88 'wn1' => <<'----------',
89 my $bg_color = $im->colorAllocate(
97 length( $options_r->{'bg_color'} )
98 ? $options_r->{'bg_color'}
99 : $MIDI::Opus::BG_color
107 'wn2' => <<'----------',
108 if ($PLATFORM eq 'aix') {
118 'wn3' => <<'----------',
119 deferred->resolve->then(
121 push @out, 'Resolve';
132 'wn4' => <<'----------',
134 # Orignal formatting looks nice but would be hard to duplicate
135 return exists $G->{ Attr }->{ E } &&
136 exists $G->{ Attr }->{ E }->{ $u } &&
137 exists $G->{ Attr }->{ E }->{ $u }->{ $v } ?
138 %{ $G->{ Attr }->{ E }->{ $u }->{ $v } } :
143 'wn5' => <<'----------',
159 'wn6' => <<'----------',
160 # illustration of some do-not-weld rules
162 # do not weld a two-line function call
163 $trans->add_transformation( PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
165 # but weld this more complex statement
166 my $compass = uc( opposite_direction( line_to_canvas_direction(
167 @{ $coords[0] }, @{ $coords[1] } ) ) );
169 # OLD: do not weld to a one-line block because the function could
170 # get separated from its opening paren.
171 # NEW: (30-jan-2021): keep one-line block together for stability
173 ( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
175 # another example; do not weld because the sub is not broken
176 $wrapped->add_around_modifier(
177 sub { push @tracelog => 'around 1'; $_[0]->(); } );
179 # but okay to weld here because the sub is broken
180 $wrapped->add_around_modifier( sub {
181 push @tracelog => 'around 1'; $_[0]->(); } );
185 ####################################
186 # BEGIN SECTION 3: Expected output #
187 ####################################
193 expect => <<'#1...........',
196 'Dr. Watson', undef, '221b', 'Baker St.',
197 undef, 'London', 'NW1', undef,
201 'Sam Gamgee', undef, undef, 'Bagshot Row',
202 undef, 'Hobbiton', undef, undef,
212 expect => <<'#2...........',
215 'Dr. Watson', undef, '221b', 'Baker St.',
216 undef, 'London', 'NW1', undef,
219 'Sam Gamgee', undef, undef, 'Bagshot Row',
220 undef, 'Hobbiton', undef, undef,
221 'The Shire', undef ], );
228 expect => <<'#3...........',
231 SOAP::Data->name('getStateName')
232 ->attr( { xmlns => 'urn:/My/Examples' } ),
234 )->result eq 'Alabama'
242 expect => <<'#4...........',
245 SOAP::Data->name('getStateName')
246 ->attr( { xmlns => 'urn:/My/Examples' } ),
247 1 )->result eq 'Alabama' );
254 expect => <<'#5...........',
256 "Sunday", "Monday", "Tuesday", "Wednesday",
257 "Thursday", "Friday", "Saturday", "Sunday"
265 expect => <<'#6...........',
267 "Sunday", "Monday", "Tuesday", "Wednesday",
268 "Thursday", "Friday", "Saturday", "Sunday" )[$wday];
275 expect => <<'#7...........',
276 my $bg_color = $im->colorAllocate(
284 length( $options_r->{'bg_color'} )
285 ? $options_r->{'bg_color'}
286 : $MIDI::Opus::BG_color
298 expect => <<'#8...........',
299 my $bg_color = $im->colorAllocate(
307 length( $options_r->{'bg_color'} )
308 ? $options_r->{'bg_color'}
309 : $MIDI::Opus::BG_color ) ) ) ) );
316 expect => <<'#9...........',
317 my $bg_color = $im->colorAllocate(
325 length( $options_r->{'bg_color'} )
326 ? $options_r->{'bg_color'}
327 : $MIDI::Opus::BG_color
339 expect => <<'#10...........',
340 my $bg_color = $im->colorAllocate( unpack(
347 length( $options_r->{'bg_color'} )
348 ? $options_r->{'bg_color'}
349 : $MIDI::Opus::BG_color
360 expect => <<'#11...........',
361 if ( $PLATFORM eq 'aix' ) {
379 expect => <<'#12...........',
380 if ( $PLATFORM eq 'aix' ) {
394 expect => <<'#13...........',
395 deferred->resolve->then(
397 push @out, 'Resolve';
412 expect => <<'#14...........',
413 deferred->resolve->then( sub {
414 push @out, 'Resolve';
426 expect => <<'#15...........',
430 # Orignal formatting looks nice but would be hard to duplicate
432 exists $G->{Attr}->{E}
433 && exists $G->{Attr}->{E}->{$u}
434 && exists $G->{Attr}->{E}->{$u}->{$v}
435 ? %{ $G->{Attr}->{E}->{$u}->{$v} }
446 expect => <<'#16...........',
449 # Orignal formatting looks nice but would be hard to duplicate
451 exists $G->{Attr}->{E}
452 && exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v}
453 ? %{ $G->{Attr}->{E}->{$u}->{$v} }
462 expect => <<'#17...........',
482 expect => <<'#18...........',
500 expect => <<'#19...........',
501 # illustration of some do-not-weld rules
503 # do not weld a two-line function call
504 $trans->add_transformation(
505 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
507 # but weld this more complex statement
510 line_to_canvas_direction(
511 @{ $coords[0] }, @{ $coords[1] }
516 # OLD: do not weld to a one-line block because the function could
517 # get separated from its opening paren.
518 # NEW: (30-jan-2021): keep one-line block together for stability
520 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
522 # another example; do not weld because the sub is not broken
523 $wrapped->add_around_modifier(
524 sub { push @tracelog => 'around 1'; $_[0]->(); } );
526 # but okay to weld here because the sub is broken
527 $wrapped->add_around_modifier(
529 push @tracelog => 'around 1';
539 expect => <<'#20...........',
540 # illustration of some do-not-weld rules
542 # do not weld a two-line function call
543 $trans->add_transformation(
544 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
546 # but weld this more complex statement
547 my $compass = uc( opposite_direction( line_to_canvas_direction(
548 @{ $coords[0] }, @{ $coords[1] }
551 # OLD: do not weld to a one-line block because the function could
552 # get separated from its opening paren.
553 # NEW: (30-jan-2021): keep one-line block together for stability
555 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
557 # another example; do not weld because the sub is not broken
558 $wrapped->add_around_modifier(
559 sub { push @tracelog => 'around 1'; $_[0]->(); } );
561 # but okay to weld here because the sub is broken
562 $wrapped->add_around_modifier( sub {
563 push @tracelog => 'around 1';
570 my $ntests = 0 + keys %{$rtests};
571 plan tests => $ntests;
578 foreach my $key ( sort keys %{$rtests} ) {
580 my $sname = $rtests->{$key}->{source};
581 my $expect = $rtests->{$key}->{expect};
582 my $pname = $rtests->{$key}->{params};
583 my $source = $rsources->{$sname};
584 my $params = defined($pname) ? $rparams->{$pname} : "";
586 my $errorfile_string;
587 my $err = Perl::Tidy::perltidy(
589 destination => \$output,
590 perltidyrc => \$params,
591 argv => '', # for safety; hide any ARGV from perltidy
592 stderr => \$stderr_string,
593 errorfile => \$errorfile_string, # not used when -se flag is set
595 if ( $err || $stderr_string || $errorfile_string ) {
596 print STDERR "Error output received for test '$key'\n";
598 print STDERR "An error flag '$err' was returned\n";
601 if ($stderr_string) {
602 print STDERR "---------------------\n";
603 print STDERR "<<STDERR>>\n$stderr_string\n";
604 print STDERR "---------------------\n";
605 ok( !$stderr_string );
607 if ($errorfile_string) {
608 print STDERR "---------------------\n";
609 print STDERR "<<.ERR file>>\n$errorfile_string\n";
610 print STDERR "---------------------\n";
611 ok( !$errorfile_string );
615 if ( !is( $output, $expect, $key ) ) {
616 my $leno = length($output);
617 my $lene = length($expect);
618 if ( $leno == $lene ) {
620 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
624 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";