1 # Created with: ./make_t.pl
11 #8 hanging_side_comments1.def
12 #9 hanging_side_comments2.def
25 # To locate test #13 you can search for its name or the string '#13'
37 ###########################################
38 # BEGIN SECTION 1: Parameter combinations #
39 ###########################################
43 'html' => <<'----------',
50 ############################
51 # BEGIN SECTION 2: Sources #
52 ############################
55 'gnu1' => <<'----------',
57 "aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot",
58 "stamp-h.in", 'stamp-vti'
62 'gnu2' => <<'----------',
63 $search_mb = $menu_bar->Menubutton(
65 '-relief' => 'raised',
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');
77 'gnu4' => <<'----------',
78 my $mzef = Bio::Tools::MZEF->new( '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
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)
86 'hanging_side_comments2' => <<'----------',
87 # keep '=' lined up even with hanging side comments
89 # hanging side comment
90 $boondoggle=5;# side comment
91 $beetle=5;# side comment
92 # hanging side comment
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,},],},);
107 'hashbang' => <<'----------',
111 'here1' => <<'----------',
112 is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
113 $Perl -le "print 'ok'"
117 'html1' => <<'----------',
118 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
119 else { $editlblk = "off"; $editlblkchecked = "unchecked" }
122 'ident1' => <<'----------',
125 print "A::new! $_[0] $_[1]\n";
129 my $scanner = new A::() ;
131 $scanner = new A 'a';
134 'if1' => <<'----------',
136 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
137 else { $editlblk = "off"; $editlblkchecked = "unchecked" }
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
147 'label1' => <<'----------',
150 print "looping with label INIT:, a=$a\n";
151 if ($a<10) {goto INIT}
161 'lextest1' => <<'----------',
163 $url = new URI::URL "http://www/"; die if $url eq "xXx";
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";}
175 ####################################
176 # BEGIN SECTION 3: Expected output #
177 ####################################
183 expect => <<'#1...........',
184 @common_sometimes = (
185 "aclocal.m4", "acconfig.h",
186 "config.h.top", "config.h.bot",
187 "stamp-h.in", 'stamp-vti'
195 expect => <<'#2...........',
196 $search_mb = $menu_bar->Menubutton(
198 '-relief' => 'raised',
210 expect => <<'#3...........',
211 $search_mb = $menu_bar->Menubutton(
213 '-relief' => 'raised',
215 )->pack('-side' => 'left',
223 expect => <<'#4...........',
224 $output_rules .= &file_contents_with_transform(
226 . $info_cursor . '/g; '
241 expect => <<'#5...........',
243 &file_contents_with_transform(
245 . $info_cursor . '/g; '
260 expect => <<'#6...........',
261 my $mzef = Bio::Tools::MZEF->new(
262 '-file' => Bio::Root::IO->catfile( "t", "genomic-seq.mzef" ) );
269 expect => <<'#7...........',
270 my $mzef = Bio::Tools::MZEF->new(
271 '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
275 'hanging_side_comments1.def' => {
276 source => "hanging_side_comments1",
278 expect => <<'#8...........',
280 $value . " "; # with a trailing space in case there are multiple values
281 # for this tag (allowed in GFF2 and .ace format)
285 'hanging_side_comments2.def' => {
286 source => "hanging_side_comments2",
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
302 expect => <<'#10...........',
305 series => "flintstones",
306 nights => [qw(monday thursday friday)],
308 { name => "fred", role => "lead", age => 36, },
314 { name => "pebbles", role => "kid", age => 4, },
319 nights => [qw(wednesday saturday)],
326 { name => "jane", role => "wife", age => 39, },
327 { name => "elroy", role => "kid", age => 9, },
331 series => "simpsons",
332 nights => [qw(monday)],
339 { name => "marge", role => "wife", age => 37, },
352 source => "hashbang",
354 expect => <<'#11...........',
362 expect => <<'#12...........',
363 is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
364 $Perl -le "print 'ok'"
372 expect => <<'#13...........',
373 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
374 else { $editlblk = "off"; $editlblkchecked = "unchecked" }
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">
387 <title>perltidy</title>
388 <style type="text/css">
390 /* default style sheet generated by perltidy */
391 body {background: #FFFFFF; color: #000000}
392 pre { color: #000000;
394 font-family: courier;
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 */
422 <!-- contents of filename: perltidy -->
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">"on"</span><span class="sc">;</span> <span class="i">$editlblkchecked</span> = <span class="q">"checked"</span> <span class="s">}</span>
425 <span class="k">else</span> <span class="s">{</span> <span class="i">$editlblk</span> = <span class="q">"off"</span><span class="sc">;</span> <span class="i">$editlblkchecked</span> = <span class="q">"unchecked"</span> <span class="s">}</span>
435 expect => <<'#15...........',
439 print "A::new! $_[0] $_[1]\n";
444 my $scanner = new A::();
446 $scanner = new A 'a';
453 expect => <<'#16...........',
455 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
456 else { $editlblk = "off"; $editlblkchecked = "unchecked" }
463 expect => <<'#17...........',
464 # -iscl will not allow alignment of hanging side comments (currently)
466 ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
467 # dev, but be more forgiving
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
486 expect => <<'#19...........',
489 print "looping with label INIT:, a=$a\n";
490 if ( $a < 10 ) { goto INIT }
502 source => "lextest1",
504 expect => <<'#20...........',
506 $url = new URI::URL "http://www/"; die if $url eq "xXx";
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";
522 my $ntests = 0 + keys %{$rtests};
523 plan tests => $ntests;
530 foreach my $key ( sort keys %{$rtests} ) {
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} : "";
538 my $errorfile_string;
539 my $err = Perl::Tidy::perltidy(
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
547 if ( $err || $stderr_string || $errorfile_string ) {
548 print STDERR "Error output received for test '$key'\n";
550 print STDERR "An error flag '$err' was returned\n";
553 if ($stderr_string) {
554 print STDERR "---------------------\n";
555 print STDERR "<<STDERR>>\n$stderr_string\n";
556 print STDERR "---------------------\n";
557 ok( !$stderr_string );
559 if ($errorfile_string) {
560 print STDERR "---------------------\n";
561 print STDERR "<<.ERR file>>\n$errorfile_string\n";
562 print STDERR "---------------------\n";
563 ok( !$errorfile_string );
567 if ( !is( $output, $expect, $key ) ) {
568 my $leno = length($output);
569 my $lene = length($expect);
570 if ( $leno == $lene ) {
572 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
576 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";