t/snippets13.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 align10.def
   5 #2 align11.def
   6 #3 align12.def
   7 #4 align13.def
   8 #5 rt127633.def
   9 #6 rt127633.rt127633
  10 #7 align14.def
  11 #8 align15.def
  12 #9 align16.def
  13 #10 break5.def
  14 #11 align19.def
  15 #12 align20.def
  16 #13 align21.def
  17 #14 align22.def
  18 #15 align23.def
  19
  20 # To locate test #13 you can search for its name or the string '#13'
  21
  22 use strict;
  23 use Test;
  24 use Carp;
  25 use Perl::Tidy;
  26 my $rparams;
  27 my $rsources;
  28 my $rtests;
  29
  30 BEGIN {
  31
  32     ###########################################
  33     # BEGIN SECTION 1: Parameter combinations #
  34     ###########################################
  35     $rparams = {
  36         'def'      => "",
  37         'rt127633' => "-baao",
  38     };
  39
  40     ############################
  41     # BEGIN SECTION 2: Sources #
  42     ############################
  43     $rsources = {
  44
  45         'align10' => <<'----------',
  46 $message =~ &rhs_wordwrap( $message, $width );
  47 $message_len =~ split( /^/, $message );
  48 ----------
  49
  50         'align11' => <<'----------',
  51 my $accountno = getnextacctno( $env, $bornum, $dbh );
  52 my $item = getiteminformation( $env, $itemno );
  53 my $account = "Insert into accountlines
  54  bla bla";
  55 ----------
  56
  57         'align12' => <<'----------',
  58     my $type = shift || "o";
  59     my $fname  = ( $type eq 'oo'               ? 'orte_city' : 'orte' );
  60     my $suffix = ( $coord_system eq 'standard' ? ''          : '-orig' );
  61 ----------
  62
  63         'align13' => <<'----------',
  64 # symbols =~ and !~ are equivalent in alignment
  65 ok( $out !~ /EXACT <fop>/, "No 'baz'" );
  66 ok( $out =~ /<liz>/,       "Got 'liz'" );    # liz
  67 ok( $out =~ /<zoo>/,       "Got 'zoo'" );    # zoo
  68 ok( $out !~ /<zap>/,       "Got 'zap'" );    # zap
  69 ----------
  70
  71         'align14' => <<'----------',
  72 # align the =
  73 my($apple)=new Fruit("Apple1",.1,.30);
  74 my($grapefruit)=new Grapefruit("Grapefruit1",.3);
  75 my($redgrapefruit)=new RedGrapefruit("Grapefruit2",.3);
  76 ----------
  77
  78         'align15' => <<'----------',
  79 # align both = and //
  80 my$color=$opts{'-color'}//'black';
  81 my$background=$opts{'-background'}//'none';
  82 my$linewidth=$opts{'-linewidth'}//1;
  83 my$radius=$opts{'-radius'}//0;
  84 ----------
  85
  86         'align16' => <<'----------',
  87 # align all at first =>
  88 use constant {
  89     PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
  90     FAMILY => [qw( John Jane Sally )],
  91     AGES   => { John => 33, Jane => 28, Sally => 3 },
  92     RFAM => [ [qw( John Jane Sally )] ],
  93     THREE => 3,
  94     SPIT  => sub { shift },
  95 };
  96
  97 ----------
  98
  99         'align19' => <<'----------',
 100 # different lhs patterns, do not align the '='
 101 @_                                       = qw(sort grep map do eval);
 102 @is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
 103 ----------
 104
 105         'align20' => <<'----------',
 106 # marginal two-line match; differnt lhs patterns; do not align
 107 $w[$i] = $t;
 108 $t = 1000000;
 109 ----------
 110
 111         'align21' => <<'----------',
 112 # two lines with large gap but same lhs pattern so align equals
 113 local (@pieces)            = split( /\./, $filename, 2 );
 114 local ($just_dir_and_base) = $pieces[0];
 115 ----------
 116
 117         'align22' => <<'----------',
 118 # two equality lines with different patterns to left of equals do not align
 119 $signame{$_} = ++$signal;
 120 $signum[$signal] = $_;
 121 ----------
 122
 123         'align23' => <<'----------',
 124 # two equality lines with same pattern on left of equals will align
 125 my $orig = my $format = "^<<<<< ~~\n";
 126 my $abc = "abc";
 127 ----------
 128
 129         'break5' => <<'----------',
 130 # do not break at .'s after the ?
 131 return (
 132     ( $pod eq $pod2 ) & amp;
 133       &amp;
 134       ( $htype eq "NAME" )
 135   )
 136   ? "\n&lt;A NAME=\""
 137   . $value
 138   . "\"&gt;\n$text&lt;/A&gt;\n"
 139   : "\n$type$pod2.html\#" . $value . "\"&gt;$text&lt;\/A&gt;\n";
 140 ----------
 141
 142         'rt127633' => <<'----------',
 143 # keep lines long; do not break after 'return' and '.' with -baoo
 144 return $ref eq 'SCALAR' ? $self->encode_scalar( $object, $name, $type, $attr ) : $ref eq 'ARRAY';
 145 my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' .  'bbbbbbbbbbbbbbbbbbbbbbbbb';
 146 ----------
 147     };
 148
 149     ####################################
 150     # BEGIN SECTION 3: Expected output #
 151     ####################################
 152     $rtests = {
 153
 154         'align10.def' => {
 155             source => "align10",
 156             params => "def",
 157             expect => <<'#1...........',
 158 $message     =~ &rhs_wordwrap( $message, $width );
 159 $message_len =~ split( /^/, $message );
 160 #1...........
 161         },
 162
 163         'align11.def' => {
 164             source => "align11",
 165             params => "def",
 166             expect => <<'#2...........',
 167 my $accountno = getnextacctno( $env, $bornum, $dbh );
 168 my $item      = getiteminformation( $env, $itemno );
 169 my $account   = "Insert into accountlines
 170  bla bla";
 171 #2...........
 172         },
 173
 174         'align12.def' => {
 175             source => "align12",
 176             params => "def",
 177             expect => <<'#3...........',
 178     my $type = shift || "o";
 179     my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
 180     my $suffix = ( $coord_system eq 'standard' ? '' : '-orig' );
 181 #3...........
 182         },
 183
 184         'align13.def' => {
 185             source => "align13",
 186             params => "def",
 187             expect => <<'#4...........',
 188 # symbols =~ and !~ are equivalent in alignment
 189 ok( $out !~ /EXACT <fop>/, "No 'baz'" );
 190 ok( $out =~ /<liz>/,       "Got 'liz'" );    # liz
 191 ok( $out =~ /<zoo>/,       "Got 'zoo'" );    # zoo
 192 ok( $out !~ /<zap>/,       "Got 'zap'" );    # zap
 193 #4...........
 194         },
 195
 196         'rt127633.def' => {
 197             source => "rt127633",
 198             params => "def",
 199             expect => <<'#5...........',
 200 # keep lines long; do not break after 'return' and '.' with -baoo
 201 return $ref eq 'SCALAR'
 202   ? $self->encode_scalar( $object, $name, $type, $attr )
 203   : $ref eq 'ARRAY';
 204 my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa'
 205   . 'bbbbbbbbbbbbbbbbbbbbbbbbb';
 206 #5...........
 207         },
 208
 209         'rt127633.rt127633' => {
 210             source => "rt127633",
 211             params => "rt127633",
 212             expect => <<'#6...........',
 213 # keep lines long; do not break after 'return' and '.' with -baoo
 214 return $ref eq 'SCALAR' ? $self->encode_scalar( $object, $name, $type, $attr ) :
 215   $ref eq 'ARRAY';
 216 my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' .
 217   'bbbbbbbbbbbbbbbbbbbbbbbbb';
 218 #6...........
 219         },
 220
 221         'align14.def' => {
 222             source => "align14",
 223             params => "def",
 224             expect => <<'#7...........',
 225 # align the =
 226 my ($apple)         = new Fruit( "Apple1", .1, .30 );
 227 my ($grapefruit)    = new Grapefruit( "Grapefruit1", .3 );
 228 my ($redgrapefruit) = new RedGrapefruit( "Grapefruit2", .3 );
 229 #7...........
 230         },
 231
 232         'align15.def' => {
 233             source => "align15",
 234             params => "def",
 235             expect => <<'#8...........',
 236 # align both = and //
 237 my $color      = $opts{'-color'}      // 'black';
 238 my $background = $opts{'-background'} // 'none';
 239 my $linewidth  = $opts{'-linewidth'}  // 1;
 240 my $radius     = $opts{'-radius'}     // 0;
 241 #8...........
 242         },
 243
 244         'align16.def' => {
 245             source => "align16",
 246             params => "def",
 247             expect => <<'#9...........',
 248 # align all at first =>
 249 use constant {
 250     PHFAM  => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
 251     FAMILY => [qw( John Jane Sally )],
 252     AGES   => { John => 33, Jane => 28, Sally => 3 },
 253     RFAM   => [ [qw( John Jane Sally )] ],
 254     THREE  => 3,
 255     SPIT   => sub { shift },
 256 };
 257
 258 #9...........
 259         },
 260
 261         'break5.def' => {
 262             source => "break5",
 263             params => "def",
 264             expect => <<'#10...........',
 265 # do not break at .'s after the ?
 266 return (
 267     ( $pod eq $pod2 ) & amp;
 268     &amp;
 269     ( $htype eq "NAME" )
 270   )
 271   ? "\n&lt;A NAME=\"" . $value . "\"&gt;\n$text&lt;/A&gt;\n"
 272   : "\n$type$pod2.html\#" . $value . "\"&gt;$text&lt;\/A&gt;\n";
 273 #10...........
 274         },
 275
 276         'align19.def' => {
 277             source => "align19",
 278             params => "def",
 279             expect => <<'#11...........',
 280 # different lhs patterns, do not align the '='
 281 @_ = qw(sort grep map do eval);
 282 @is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
 283 #11...........
 284         },
 285
 286         'align20.def' => {
 287             source => "align20",
 288             params => "def",
 289             expect => <<'#12...........',
 290 # marginal two-line match; differnt lhs patterns; do not align
 291 $w[$i] = $t;
 292 $t = 1000000;
 293 #12...........
 294         },
 295
 296         'align21.def' => {
 297             source => "align21",
 298             params => "def",
 299             expect => <<'#13...........',
 300 # two lines with large gap but same lhs pattern so align equals
 301 local (@pieces)            = split( /\./, $filename, 2 );
 302 local ($just_dir_and_base) = $pieces[0];
 303 #13...........
 304         },
 305
 306         'align22.def' => {
 307             source => "align22",
 308             params => "def",
 309             expect => <<'#14...........',
 310 # two equality lines with different patterns to left of equals do not align
 311 $signame{$_} = ++$signal;
 312 $signum[$signal] = $_;
 313 #14...........
 314         },
 315
 316         'align23.def' => {
 317             source => "align23",
 318             params => "def",
 319             expect => <<'#15...........',
 320 # two equality lines with same pattern on left of equals will align
 321 my $orig = my $format = "^<<<<< ~~\n";
 322 my $abc  = "abc";
 323 #15...........
 324         },
 325     };
 326
 327     my $ntests = 0 + keys %{$rtests};
 328     plan tests => $ntests;
 329 }
 330
 331 ###############
 332 # EXECUTE TESTS
 333 ###############
 334
 335 foreach my $key ( sort keys %{$rtests} ) {
 336     my $output;
 337     my $sname  = $rtests->{$key}->{source};
 338     my $expect = $rtests->{$key}->{expect};
 339     my $pname  = $rtests->{$key}->{params};
 340     my $source = $rsources->{$sname};
 341     my $params = defined($pname) ? $rparams->{$pname} : "";
 342     my $stderr_string;
 343     my $errorfile_string;
 344     my $err = Perl::Tidy::perltidy(
 345         source      => \$source,
 346         destination => \$output,
 347         perltidyrc  => \$params,
 348         argv        => '',             # for safety; hide any ARGV from perltidy
 349         stderr      => \$stderr_string,
 350         errorfile => \$errorfile_string,    # not used when -se flag is set
 351     );
 352     if ( $err || $stderr_string || $errorfile_string ) {
 353         if ($err) {
 354             print STDERR
 355 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 356             ok( !$err );
 357         }
 358         if ($stderr_string) {
 359             print STDERR "---------------------\n";
 360             print STDERR "<<STDERR>>\n$stderr_string\n";
 361             print STDERR "---------------------\n";
 362             print STDERR
 363 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 364             ok( !$stderr_string );
 365         }
 366         if ($errorfile_string) {
 367             print STDERR "---------------------\n";
 368             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 369             print STDERR "---------------------\n";
 370             print STDERR
 371 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 372             ok( !$errorfile_string );
 373         }
 374     }
 375     else {
 376         ok( $output, $expect );
 377     }
 378 }