t/snippets4.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 gnu1.gnu
   5 #2 gnu2.def
   6 #3 gnu2.gnu
   7 #4 gnu3.def
   8 #5 gnu3.gnu
   9 #6 gnu4.def
  10 #7 gnu4.gnu
  11 #8 hanging_side_comments1.def
  12 #9 hanging_side_comments2.def
  13 #10 hash1.def
  14 #11 hashbang.def
  15 #12 here1.def
  16 #13 html1.def
  17 #14 html1.html
  18 #15 ident1.def
  19 #16 if1.def
  20 #17 iscl1.def
  21 #18 iscl1.iscl
  22 #19 label1.def
  23 #20 lextest1.def
  24
  25 # To locate test #13 you can search for its name or the string '#13'
  26
  27 use strict;
  28 use Test;
  29 use Carp;
  30 use Perl::Tidy;
  31 my $rparams;
  32 my $rsources;
  33 my $rtests;
  34
  35 BEGIN {
  36
  37     ###########################################
  38     # BEGIN SECTION 1: Parameter combinations #
  39     ###########################################
  40     $rparams = {
  41         'def'  => "",
  42         'gnu'  => "-gnu",
  43         'html' => <<'----------',
  44 -fmt="html"
  45 -nts
  46 ----------
  47         'iscl' => "-iscl",
  48     };
  49
  50     ############################
  51     # BEGIN SECTION 2: Sources #
  52     ############################
  53     $rsources = {
  54
  55         'gnu1' => <<'----------',
  56 @common_sometimes = (
  57     "aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot",
  58     "stamp-h.in", 'stamp-vti'
  59 );
  60 ----------
  61
  62         'gnu2' => <<'----------',
  63 $search_mb = $menu_bar->Menubutton(
  64     '-text'        => 'Search',
  65     '-relief'      => 'raised',
  66     '-borderwidth' => 2,
  67 )->pack(
  68     '-side' => 'left',
  69     '-padx' => 2
  70 );
  71 ----------
  72
  73         'gnu3' => <<'----------',
  74 $output_rules .= &file_contents_with_transform( 's/\@TEXI\@/' . $info_cursor . '/g; ' . 's/\@VTI\@/' . $vti . '/g; ' . 's/\@VTEXI\@/' . $vtexi . '/g;' . 's,\@MDDIR\@,' . $conf_pat . ',g;', 'texi-vers');
  75 ----------
  76
  77         'gnu4' => <<'----------',
  78 my $mzef = Bio::Tools::MZEF->new( '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
  79 ----------
  80
  81         'hanging_side_comments1' => <<'----------',
  82 $valuestr .= $value . " " ;    # with a trailing space in case there are multiple values
  83    # for this tag (allowed in GFF2 and .ace format)
  84 ----------
  85
  86         'hanging_side_comments2' => <<'----------',
  87 # keep '=' lined up even with hanging side comments
  88 $ax=1;# side comment
  89  # hanging side comment
  90 $boondoggle=5;# side comment
  91 $beetle=5;# side comment
  92  # hanging side comment
  93 $d=3;
  94 ----------
  95
  96         'hash1' => <<'----------',
  97 %TV=(flintstones=>{series=>"flintstones",nights=>[qw(monday thursday friday)],
  98 members=>[{name=>"fred",role=>"lead",age=>36,},{name=>"wilma",role=>"wife",
  99 age=>31,},{name=>"pebbles",role=>"kid",age=>4,},],},jetsons=>{series=>"jetsons",
 100 nights=>[qw(wednesday saturday)],members=>[{name=>"george",role=>"lead",age=>41,
 101 },{name=>"jane",role=>"wife",age=>39,},{name=>"elroy",role=>"kid",age=>9,},],},
 102 simpsons=>{series=>"simpsons",nights=>[qw(monday)],members=>[{name=>"homer",
 103 role=>"lead",age=>34,},{name=>"marge",role=>"wife",age=>37,},{name=>"bart",
 104 role=>"kid",age=>11,},],},);
 105 ----------
 106
 107         'hashbang' => <<'----------',
 108 #!/usr/bin/perl
 109 ----------
 110
 111         'here1' => <<'----------',
 112 is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
 113   $Perl -le "print 'ok'"
 114   END
 115 ----------
 116
 117         'html1' => <<'----------',
 118 if   ( $editlblk eq 1 ) { $editlblk = "on";  $editlblkchecked = "checked" }
 119 else                    { $editlblk = "off"; $editlblkchecked = "unchecked" }
 120 ----------
 121
 122         'ident1' => <<'----------',
 123 package A;
 124 sub new  {
 125    print "A::new! $_[0] $_[1]\n";
 126    return 1;
 127 }
 128 package main;
 129 my $scanner = new A::() ;
 130 $scanner = new A::;
 131 $scanner = new A 'a';
 132 ----------
 133
 134         'if1' => <<'----------',
 135 # one-line blocks
 136 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
 137 else { $editlblk = "off"; $editlblkchecked = "unchecked" }
 138 ----------
 139
 140         'iscl1' => <<'----------',
 141         # -iscl will not allow alignment of hanging side comments (currently)
 142         $gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
 143                # dev, but be more forgiving
 144                # for releases
 145 ----------
 146
 147         'label1' => <<'----------',
 148 INIT : {
 149 $a++;
 150 print "looping with label INIT:, a=$a\n";
 151   if ($a<10) {goto INIT}
 152 }
 153 package: {
 154     print "hello!\n";
 155 }
 156 sub: {
 157     print "hello!\n";
 158 }
 159 ----------
 160
 161         'lextest1' => <<'----------',
 162 $_= <<'EOL';
 163    $url = new URI::URL "http://www/";   die if $url eq "xXx";
 164 EOL
 165 LOOP:{print(" digits"),redo LOOP if/\G\d+\b[,.;]?\s*/gc;print(" lowercase"),
 166 redo LOOP if/\G[a-z]+\b[,.;]?\s*/gc;print(" UPPERCASE"), redo
 167 LOOP if/\G[A-Z]+\b[,.;]?\s*/gc;print(" Capitalized"),
 168 redo LOOP if/\G[A-Z][a-z]+\b[,.;]?\s*/gc;
 169 print(" MiXeD"),redo LOOP if/\G[A-Za-z]+\b[,.;]?\s*/gc;print(
 170 " alphanumeric"),redo LOOP if/\G[A-Za-z0-9]+\b[,.;]?\s*/gc;print(" line-noise"
 171 ),redo LOOP if/\G[^A-Za-z0-9]+/gc;print". That's all!\n";}
 172 ----------
 173     };
 174
 175     ####################################
 176     # BEGIN SECTION 3: Expected output #
 177     ####################################
 178     $rtests = {
 179
 180         'gnu1.gnu' => {
 181             source => "gnu1",
 182             params => "gnu",
 183             expect => <<'#1...........',
 184 @common_sometimes = (
 185                      "aclocal.m4",   "acconfig.h",
 186                      "config.h.top", "config.h.bot",
 187                      "stamp-h.in",   'stamp-vti'
 188                     );
 189 #1...........
 190         },
 191
 192         'gnu2.def' => {
 193             source => "gnu2",
 194             params => "def",
 195             expect => <<'#2...........',
 196 $search_mb = $menu_bar->Menubutton(
 197     '-text'        => 'Search',
 198     '-relief'      => 'raised',
 199     '-borderwidth' => 2,
 200 )->pack(
 201     '-side' => 'left',
 202     '-padx' => 2
 203 );
 204 #2...........
 205         },
 206
 207         'gnu2.gnu' => {
 208             source => "gnu2",
 209             params => "gnu",
 210             expect => <<'#3...........',
 211 $search_mb = $menu_bar->Menubutton(
 212                                    '-text'        => 'Search',
 213                                    '-relief'      => 'raised',
 214                                    '-borderwidth' => 2,
 215   )->pack('-side' => 'left',
 216           '-padx' => 2);
 217 #3...........
 218         },
 219
 220         'gnu3.def' => {
 221             source => "gnu3",
 222             params => "def",
 223             expect => <<'#4...........',
 224 $output_rules .= &file_contents_with_transform(
 225     's/\@TEXI\@/'
 226       . $info_cursor . '/g; '
 227       . 's/\@VTI\@/'
 228       . $vti . '/g; '
 229       . 's/\@VTEXI\@/'
 230       . $vtexi . '/g;'
 231       . 's,\@MDDIR\@,'
 232       . $conf_pat . ',g;',
 233     'texi-vers'
 234 );
 235 #4...........
 236         },
 237
 238         'gnu3.gnu' => {
 239             source => "gnu3",
 240             params => "gnu",
 241             expect => <<'#5...........',
 242 $output_rules .=
 243   &file_contents_with_transform(
 244                                 's/\@TEXI\@/'
 245                                   . $info_cursor . '/g; '
 246                                   . 's/\@VTI\@/'
 247                                   . $vti . '/g; '
 248                                   . 's/\@VTEXI\@/'
 249                                   . $vtexi . '/g;'
 250                                   . 's,\@MDDIR\@,'
 251                                   . $conf_pat . ',g;',
 252                                 'texi-vers'
 253                                );
 254 #5...........
 255         },
 256
 257         'gnu4.def' => {
 258             source => "gnu4",
 259             params => "def",
 260             expect => <<'#6...........',
 261 my $mzef = Bio::Tools::MZEF->new(
 262     '-file' => Bio::Root::IO->catfile( "t", "genomic-seq.mzef" ) );
 263 #6...........
 264         },
 265
 266         'gnu4.gnu' => {
 267             source => "gnu4",
 268             params => "gnu",
 269             expect => <<'#7...........',
 270 my $mzef = Bio::Tools::MZEF->new(
 271                     '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
 272 #7...........
 273         },
 274
 275         'hanging_side_comments1.def' => {
 276             source => "hanging_side_comments1",
 277             params => "def",
 278             expect => <<'#8...........',
 279 $valuestr .=
 280   $value . " ";    # with a trailing space in case there are multiple values
 281                    # for this tag (allowed in GFF2 and .ace format)
 282 #8...........
 283         },
 284
 285         'hanging_side_comments2.def' => {
 286             source => "hanging_side_comments2",
 287             params => "def",
 288             expect => <<'#9...........',
 289 # keep '=' lined up even with hanging side comments
 290 $ax         = 1;    # side comment
 291                     # hanging side comment
 292 $boondoggle = 5;    # side comment
 293 $beetle     = 5;    # side comment
 294                     # hanging side comment
 295 $d          = 3;
 296 #9...........
 297         },
 298
 299         'hash1.def' => {
 300             source => "hash1",
 301             params => "def",
 302             expect => <<'#10...........',
 303 %TV = (
 304     flintstones => {
 305         series  => "flintstones",
 306         nights  => [qw(monday thursday friday)],
 307         members => [
 308             { name => "fred", role => "lead", age => 36, },
 309             {
 310                 name => "wilma",
 311                 role => "wife",
 312                 age  => 31,
 313             },
 314             { name => "pebbles", role => "kid", age => 4, },
 315         ],
 316     },
 317     jetsons => {
 318         series  => "jetsons",
 319         nights  => [qw(wednesday saturday)],
 320         members => [
 321             {
 322                 name => "george",
 323                 role => "lead",
 324                 age  => 41,
 325             },
 326             { name => "jane",  role => "wife", age => 39, },
 327             { name => "elroy", role => "kid",  age => 9, },
 328         ],
 329     },
 330     simpsons => {
 331         series  => "simpsons",
 332         nights  => [qw(monday)],
 333         members => [
 334             {
 335                 name => "homer",
 336                 role => "lead",
 337                 age  => 34,
 338             },
 339             { name => "marge", role => "wife", age => 37, },
 340             {
 341                 name => "bart",
 342                 role => "kid",
 343                 age  => 11,
 344             },
 345         ],
 346     },
 347 );
 348 #10...........
 349         },
 350
 351         'hashbang.def' => {
 352             source => "hashbang",
 353             params => "def",
 354             expect => <<'#11...........',
 355 #!/usr/bin/perl
 356 #11...........
 357         },
 358
 359         'here1.def' => {
 360             source => "here1",
 361             params => "def",
 362             expect => <<'#12...........',
 363 is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
 364   $Perl -le "print 'ok'"
 365   END
 366 #12...........
 367         },
 368
 369         'html1.def' => {
 370             source => "html1",
 371             params => "def",
 372             expect => <<'#13...........',
 373 if   ( $editlblk eq 1 ) { $editlblk = "on";  $editlblkchecked = "checked" }
 374 else                    { $editlblk = "off"; $editlblkchecked = "unchecked" }
 375 #13...........
 376         },
 377
 378         'html1.html' => {
 379             source => "html1",
 380             params => "html",
 381             expect => <<'#14...........',
 382 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 383    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 384 <!-- Generated by perltidy  -->
 385 <html xmlns="http://www.w3.org/1999/xhtml">
 386 <head>
 387 <title>perltidy</title>
 388 <style type="text/css">
 389 <!--
 390 /* default style sheet generated by perltidy */
 391 body {background: #FFFFFF; color: #000000}
 392 pre { color: #000000;
 393       background: #FFFFFF;
 394       font-family: courier;
 395     }
 396
 397 .c  { color: #228B22;} /* comment */
 398 .cm { color: #000000;} /* comma */
 399 .co { color: #000000;} /* colon */
 400 .h  { color: #CD5555; font-weight:bold;} /* here-doc-target */
 401 .hh { color: #CD5555; font-style:italic;} /* here-doc-text */
 402 .i  { color: #00688B;} /* identifier */
 403 .j  { color: #CD5555; font-weight:bold;} /* label */
 404 .k  { color: #8B008B; font-weight:bold;} /* keyword */
 405 .m  { color: #FF0000; font-weight:bold;} /* subroutine */
 406 .n  { color: #B452CD;} /* numeric */
 407 .p  { color: #000000;} /* paren */
 408 .pd { color: #228B22; font-style:italic;} /* pod-text */
 409 .pu { color: #000000;} /* punctuation */
 410 .q  { color: #CD5555;} /* quote */
 411 .s  { color: #000000;} /* structure */
 412 .sc { color: #000000;} /* semicolon */
 413 .v  { color: #B452CD;} /* v-string */
 414 .w  { color: #000000;} /* bareword */
 415 -->
 416 </style>
 417 </head>
 418 <body>
 419 <a name="-top-"></a>
 420 <h1>perltidy</h1>
 421 <hr />
 422 <!-- contents of filename: perltidy -->
 423 <pre>
 424 <span class="k">if</span>   <span class="s">(</span> <span class="i">$editlblk</span> <span class="k">eq</span> <span class="n">1</span> <span class="s">)</span> <span class="s">{</span> <span class="i">$editlblk</span> = <span class="q">&quot;on&quot;</span><span class="sc">;</span>  <span class="i">$editlblkchecked</span> = <span class="q">&quot;checked&quot;</span> <span class="s">}</span>
 425 <span class="k">else</span>                    <span class="s">{</span> <span class="i">$editlblk</span> = <span class="q">&quot;off&quot;</span><span class="sc">;</span> <span class="i">$editlblkchecked</span> = <span class="q">&quot;unchecked&quot;</span> <span class="s">}</span>
 426 </pre>
 427 </body>
 428 </html>
 429 #14...........
 430         },
 431
 432         'ident1.def' => {
 433             source => "ident1",
 434             params => "def",
 435             expect => <<'#15...........',
 436 package A;
 437
 438 sub new {
 439     print "A::new! $_[0] $_[1]\n";
 440     return 1;
 441 }
 442
 443 package main;
 444 my $scanner = new A::();
 445 $scanner = new A::;
 446 $scanner = new A 'a';
 447 #15...........
 448         },
 449
 450         'if1.def' => {
 451             source => "if1",
 452             params => "def",
 453             expect => <<'#16...........',
 454 # one-line blocks
 455 if   ( $editlblk eq 1 ) { $editlblk = "on";  $editlblkchecked = "checked" }
 456 else                    { $editlblk = "off"; $editlblkchecked = "unchecked" }
 457 #16...........
 458         },
 459
 460         'iscl1.def' => {
 461             source => "iscl1",
 462             params => "def",
 463             expect => <<'#17...........',
 464         # -iscl will not allow alignment of hanging side comments (currently)
 465         $gsmatch =
 466           ( $sub >= 50 ) ? "equal" : "lequal";    # Force an equal match for
 467                                                   # dev, but be more forgiving
 468                                                   # for releases
 469 #17...........
 470         },
 471
 472         'iscl1.iscl' => {
 473             source => "iscl1",
 474             params => "iscl",
 475             expect => <<'#18...........',
 476         # -iscl will not allow alignment of hanging side comments (currently)
 477         $gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
 478                # dev, but be more forgiving
 479                # for releases
 480 #18...........
 481         },
 482
 483         'label1.def' => {
 484             source => "label1",
 485             params => "def",
 486             expect => <<'#19...........',
 487 INIT: {
 488     $a++;
 489     print "looping with label INIT:, a=$a\n";
 490     if ( $a < 10 ) { goto INIT }
 491 }
 492 package: {
 493     print "hello!\n";
 494 }
 495 sub: {
 496     print "hello!\n";
 497 }
 498 #19...........
 499         },
 500
 501         'lextest1.def' => {
 502             source => "lextest1",
 503             params => "def",
 504             expect => <<'#20...........',
 505 $_ = <<'EOL';
 506    $url = new URI::URL "http://www/";   die if $url eq "xXx";
 507 EOL
 508 LOOP: {
 509     print(" digits"),       redo LOOP if /\G\d+\b[,.;]?\s*/gc;
 510     print(" lowercase"),    redo LOOP if /\G[a-z]+\b[,.;]?\s*/gc;
 511     print(" UPPERCASE"),    redo LOOP if /\G[A-Z]+\b[,.;]?\s*/gc;
 512     print(" Capitalized"),  redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/gc;
 513     print(" MiXeD"),        redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/gc;
 514     print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/gc;
 515     print(" line-noise"),   redo LOOP if /\G[^A-Za-z0-9]+/gc;
 516     print ". That's all!\n";
 517 }
 518 #20...........
 519         },
 520     };
 521
 522     my $ntests = 0 + keys %{$rtests};
 523     plan tests => $ntests;
 524 }
 525
 526 ###############
 527 # EXECUTE TESTS
 528 ###############
 529
 530 foreach my $key ( sort keys %{$rtests} ) {
 531     my $output;
 532     my $sname  = $rtests->{$key}->{source};
 533     my $expect = $rtests->{$key}->{expect};
 534     my $pname  = $rtests->{$key}->{params};
 535     my $source = $rsources->{$sname};
 536     my $params = defined($pname) ? $rparams->{$pname} : "";
 537     my $stderr_string;
 538     my $errorfile_string;
 539     my $err = Perl::Tidy::perltidy(
 540         source      => \$source,
 541         destination => \$output,
 542         perltidyrc  => \$params,
 543         argv        => '',             # for safety; hide any ARGV from perltidy
 544         stderr      => \$stderr_string,
 545         errorfile => \$errorfile_string,    # not used when -se flag is set
 546     );
 547     if ( $err || $stderr_string || $errorfile_string ) {
 548         if ($err) {
 549             print STDERR
 550 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 551             ok( !$err );
 552         }
 553         if ($stderr_string) {
 554             print STDERR "---------------------\n";
 555             print STDERR "<<STDERR>>\n$stderr_string\n";
 556             print STDERR "---------------------\n";
 557             print STDERR
 558 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 559             ok( !$stderr_string );
 560         }
 561         if ($errorfile_string) {
 562             print STDERR "---------------------\n";
 563             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 564             print STDERR "---------------------\n";
 565             print STDERR
 566 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 567             ok( !$errorfile_string );
 568         }
 569     }
 570     else {
 571         ok( $output, $expect );
 572     }
 573 }