t/snippets14.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 else1.def
   5 #2 else2.def
   6 #3 ternary3.def
   7 #4 align17.def
   8 #5 align18.def
   9 #6 kgb1.def
  10 #7 kgb1.kgb
  11 #8 kgb2.def
  12 #9 kgb2.kgb
  13 #10 kgb3.def
  14 #11 kgb3.kgb
  15 #12 kgb4.def
  16 #13 kgb4.kgb
  17 #14 kgb5.def
  18 #15 kgb5.kgb
  19 #16 kgbd.def
  20 #17 kgbd.kgbd
  21 #18 kgb_tight.def
  22 #19 gnu5.def
  23
  24 # To locate test #13 you can search for its name or the string '#13'
  25
  26 use strict;
  27 use Test;
  28 use Carp;
  29 use Perl::Tidy;
  30 my $rparams;
  31 my $rsources;
  32 my $rtests;
  33
  34 BEGIN {
  35
  36     ###########################################
  37     # BEGIN SECTION 1: Parameter combinations #
  38     ###########################################
  39     $rparams = {
  40         'def'  => "",
  41         'kgb'  => "-kgb",
  42         'kgbd' => "-kgbd -kgb",
  43     };
  44
  45     ############################
  46     # BEGIN SECTION 2: Sources #
  47     ############################
  48     $rsources = {
  49
  50         'align17' => <<'----------',
  51 # align => even at broken sub block
  52 my%opt=(
  53 'cc'=>sub{$param::cachecom=1;},
  54 'cd'=>sub{$param::cachedisable=1;},
  55 'p'=>sub{
  56 $param::pflag=1;
  57 $param::build=0;
  58 }
  59 );
  60 ----------
  61
  62         'align18' => <<'----------',
  63 #align '&&'
  64 for($ENV{HTTP_USER_AGENT}){
  65 $page=
  66 /Mac/&&'m/Macintrash.html'
  67 ||/Win(dows)?NT/&&'e/evilandrude.html'
  68 ||/Win|MSIE|WebTV/&&'m/MicroslothWindows.html'
  69 ||/Linux/&&'l/Linux.html'
  70 ||/HP-UX/&&'h/HP-SUX.html'
  71 ||/SunOS/&&'s/ScumOS.html'
  72 ||'a/AppendixB.html';
  73 }
  74 ----------
  75
  76         'else1' => <<'----------',
  77 # pad after 'if' when followed by 'elsif'
  78 if    ( not defined $dir or not length $dir ) { $rslt = ''; }
  79 elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s )    { $rslt = $dir; }
  80 else                                          { $rslt = vmspath($dir); }
  81 ----------
  82
  83         'else2' => <<'----------',
  84         # no pad after 'if' when followed by 'else'
  85         if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
  86         else                   { print " " }
  87 ----------
  88
  89         'gnu5' => <<'----------',
  90         # side comments limit gnu type formatting with l=80; note extra comma
  91         push @tests, [
  92             "Lowest code point requiring 13 bytes to represent",    # 2**36
  93             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
  94             ($::is64bit) ? 0x1000000000 : -1,    # overflows on 32bit
  95           ],
  96           ;
  97 ----------
  98
  99         'kgb1' => <<'----------',
 100 # a variety of line types for testing -kgb
 101 use strict;
 102 use Test;
 103 use Encode qw(from_to encode decode
 104   encode_utf8 decode_utf8
 105   find_encoding is_utf8);
 106 use charnames qw(greek);
 107 our $targetdir = "/usr/local/doc/HTML/Perl";
 108 local (
 109     $tocfile,   $loffile,   $lotfile,         $footfile,
 110     $citefile,  $idxfile,   $figure_captions, $table_captions,
 111     $footnotes, $citations, %font_size,       %index,
 112     %done,      $t_title,   $t_author,        $t_date,
 113     $t_address, $t_affil,   $changed
 114 );
 115 my @UNITCHECKs =
 116     B::unitcheck_av->isa("B::AV")
 117   ? B::unitcheck_av->ARRAY
 118   : ();
 119 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 120 my $dna  = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
 121 my $min  = 1;
 122 my $max  = length($dnasequence);
 123 my $T = $G->_strongly_connected;
 124 my %R = $T->vertex_roots;
 125 my @C;    # We're not calling the strongly_connected_components()
 126           # Do not separate this hanging side comment from previous
 127 my $G = shift;
 128 my $exon = Bio::LiveSeq::Exon->new(
 129     -seq    => $dna,
 130     -start  => $min,
 131     -end    => $max,
 132     -strand => 1
 133 );
 134 my $octal_mode;
 135 my @inputs = (
 136     0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
 137     0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
 138 );
 139 my $impulse =
 140   ( 1 - $factor ) * ( 170 - $u ) +
 141   ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
 142 my $r = q{
 143 pm_to_blib: $(TO_INST_PM)
 144 };
 145 my $regcomp_re =
 146   "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
 147 my $position = List::MoreUtils::firstidx {
 148     refaddr $_ == $key
 149 }
 150 my @exons = ($exon);
 151 my $fastafile2 = "/tmp/tmpfastafile2";
 152 my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
 153 my $alignprogram =
 154 "/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
 155   ;                                                               # ALIGN
 156 my $xml      = new Mioga::XML::Simple( forcearray => 1 );
 157 my $xml_tree = $xml->XMLin($skel_file);
 158 my $skel_name =
 159   ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
 160 my $grp = GroupGetValues( $conf->{dbh}, $group_id );
 161 my $adm_profile =
 162   ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
 163 my $harness = TAP::Harness->new(
 164     { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
 165 require File::Temp;
 166 require Time::HiRes;
 167 my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
 168 use File::Basename qw[dirname];
 169 my $dirname = dirname($filename);
 170 my $CUT         = qr/\n=cut.*$EOP/;
 171 my $pod_or_DATA = qr/
 172               ^=(?:head[1-4]|item) .*? $CUT
 173             | ^=pod .*? $CUT
 174             | ^=for .*? $CUT
 175             | ^=begin .*? $CUT
 176             | ^__(DATA|END)__\r?\n.*
 177             /smx;
 178 require Cwd;
 179 ( my $boot = $self->{NAME} ) =~ s/:/_/g;
 180 doit(
 181 sub { @E::ISA = qw/F/ },
 182 sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
 183 sub { @C::ISA = qw//; @A::ISA = qw/K/ },
 184 sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
 185 sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
 186 sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
 187 sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
 188 sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
 189 return;
 190 );
 191 my %extractor_for = (
 192     quotelike => [ $ws, $variable,    $id, { MATCH => \&extract_quotelike } ],
 193     regex     => [ $ws, $pod_or_DATA, $id, $exql ],
 194     string    => [ $ws, $pod_or_DATA, $id, $exql ],
 195     code => [
 196         $ws,            { DONT_MATCH => $pod_or_DATA },
 197         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 198     ],
 199     code_no_comments => [
 200         { DONT_MATCH => $comment },
 201         $ncws,          { DONT_MATCH => $pod_or_DATA },
 202         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 203     ],
 204     executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
 205     executable_no_comments =>
 206       [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
 207     all => [ { MATCH => qr/(?s:.*)/ } ],
 208 );
 209 exit 1;
 210 ----------
 211
 212         'kgb2' => <<'----------',
 213 # with -kgb, do no break after last my
 214 sub next_sibling {
 215         my $self     = shift;
 216         my $parent   = $_PARENT{refaddr $self} or return '';
 217         my $key      = refaddr $self;
 218         my $elements = $parent->{children};
 219         my $position = List::MoreUtils::firstidx {
 220                 refaddr $_ == $key
 221                 } @$elements;
 222         $elements->[$position + 1] || '';
 223 }
 224
 225 ----------
 226
 227         'kgb3' => <<'----------',
 228 #!/usr/bin/perl -w
 229 use strict;  # with -kgb, no break after hash bang
 230 our ( @Changed, $TAP );  # break after isolated 'our'
 231 use File::Compare;
 232 use Symbol;
 233 use Text::Wrap();
 234 use Text::Warp();
 235 use Blast::IPS::MathUtils qw(
 236   set_interpolation_points
 237   table_row_interpolation
 238   two_point_interpolation
 239 );  # with -kgb, break around isolated 'local' below
 240 use Text::Warp();
 241 local($delta2print) =
 242         (defined $size) ? int($size/50) : $defaultdelta2print;
 243 print "break before this line\n";
 244 ----------
 245
 246         'kgb4' => <<'----------',
 247 print "hello"; # with -kgb, break after this line
 248 use strict;
 249 use warnings;
 250 use Test::More tests => 1;
 251 use Pod::Simple::XHTML;
 252 my $c = <<EOF;
 253 =head1 Documentation
 254 The keyword group dies here
 255 Do not put a blank line in this here-doc
 256 EOF
 257 my $d = $c ."=cut\n";
 258 exit 1;
 259 _END_
 260 ----------
 261
 262         'kgb5' => <<'----------',
 263 # with -kgb, do not put blank in ternary
 264 print "Starting\n"; # with -kgb, break after this line
 265 my $A = "1";
 266 my $B = "0";
 267 my $C = "1";
 268 my $D = "1";
 269 my $result =
 270     $A
 271   ? $B
 272       ? $C
 273           ? "+A +B +C"
 274           : "+A +B -C"
 275       : "+A -B"
 276   : "-A";
 277 my $F = "0";
 278 print "with -kgb, put blank above this line; result=$result\n";
 279 ----------
 280
 281         'kgb_tight' => <<'----------',
 282 # a variety of line types for testing -kgb
 283 use strict;
 284 use Test;
 285 use Encode qw(from_to encode decode
 286   encode_utf8 decode_utf8
 287   find_encoding is_utf8);
 288
 289 use charnames qw(greek);
 290 our $targetdir = "/usr/local/doc/HTML/Perl";
 291
 292 local (
 293     $tocfile,   $loffile,   $lotfile,         $footfile,
 294     $citefile,  $idxfile,   $figure_captions, $table_captions,
 295     $footnotes, $citations, %font_size,       %index,
 296     %done,      $t_title,   $t_author,        $t_date,
 297     $t_address, $t_affil,   $changed
 298 );
 299 my @UNITCHECKs =
 300     B::unitcheck_av->isa("B::AV")
 301   ? B::unitcheck_av->ARRAY
 302   : ();
 303
 304 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 305 my $dna  = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
 306 my $min  = 1;
 307 my $max  = length($dnasequence);
 308 my $T = $G->_strongly_connected;
 309
 310 my %R = $T->vertex_roots;
 311 my @C;    # We're not calling the strongly_connected_components()
 312           # Do not separate this hanging side comment from previous
 313
 314 my $G = shift;
 315
 316 my $exon = Bio::LiveSeq::Exon->new(
 317     -seq    => $dna,
 318     -start  => $min,
 319     -end    => $max,
 320     -strand => 1
 321 );
 322 my @inputs = (
 323     0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
 324     0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
 325 );
 326 my $impulse =
 327   ( 1 - $factor ) * ( 170 - $u ) +
 328   ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
 329 my $r = q{
 330 pm_to_blib: $(TO_INST_PM)
 331 };
 332 my $regcomp_re =
 333   "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
 334 my $position = List::MoreUtils::firstidx {
 335     refaddr $_ == $key
 336 }
 337
 338 my $alignprogram =
 339 "/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
 340   ;                                                               # ALIGN
 341 my $skel_name =
 342   ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
 343 my $grp = GroupGetValues( $conf->{dbh}, $group_id );
 344
 345 my $adm_profile =
 346   ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
 347 my $harness = TAP::Harness->new(
 348     { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
 349 require File::Temp;
 350
 351 require Time::HiRes;
 352
 353 my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
 354 use File::Basename qw[dirname];
 355 my $dirname = dirname($filename);
 356 my $CUT         = qr/\n=cut.*$EOP/;
 357
 358 my $pod_or_DATA = qr/
 359               ^=(?:head[1-4]|item) .*? $CUT
 360             | ^=pod .*? $CUT
 361             | ^=for .*? $CUT
 362             | ^=begin .*? $CUT
 363             | ^__(DATA|END)__\r?\n.*
 364             /smx;
 365
 366 require Cwd;
 367 print "continuing\n";
 368 exit 1;
 369 ----------
 370
 371         'kgbd' => <<'----------',
 372 package A1::B2;
 373
 374 use strict;
 375
 376 require Exporter;
 377 use A1::Context;
 378
 379 use A1::Database;
 380 use A1::Bibliotek;
 381 use A1::Author;
 382 use A1::Title;
 383
 384 use vars qw($VERSION @ISA @EXPORT);
 385 $VERSION = 0.01;
 386 ----------
 387
 388         'ternary3' => <<'----------',
 389 # this previously caused trouble because of the = and =~
 390 push( @aligns,
 391       ( ( $a = shift @a ) =~ /[^n]/ ) ? $a
 392     : (@isnum) ? 'n'
 393     :            'l' )
 394   unless $opt_a;
 395 ----------
 396     };
 397
 398     ####################################
 399     # BEGIN SECTION 3: Expected output #
 400     ####################################
 401     $rtests = {
 402
 403         'else1.def' => {
 404             source => "else1",
 405             params => "def",
 406             expect => <<'#1...........',
 407 # pad after 'if' when followed by 'elsif'
 408 if    ( not defined $dir or not length $dir ) { $rslt = ''; }
 409 elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s )    { $rslt = $dir; }
 410 else                                          { $rslt = vmspath($dir); }
 411 #1...........
 412         },
 413
 414         'else2.def' => {
 415             source => "else2",
 416             params => "def",
 417             expect => <<'#2...........',
 418         # no pad after 'if' when followed by 'else'
 419         if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
 420         else                   { print " " }
 421 #2...........
 422         },
 423
 424         'ternary3.def' => {
 425             source => "ternary3",
 426             params => "def",
 427             expect => <<'#3...........',
 428 # this previously caused trouble because of the = and =~
 429 push(
 430     @aligns,
 431     ( ( $a = shift @a ) =~ /[^n]/ ) ? $a
 432     : (@isnum)                      ? 'n'
 433     :                                 'l'
 434 ) unless $opt_a;
 435 #3...........
 436         },
 437
 438         'align17.def' => {
 439             source => "align17",
 440             params => "def",
 441             expect => <<'#4...........',
 442 # align => even at broken sub block
 443 my %opt = (
 444     'cc' => sub { $param::cachecom     = 1; },
 445     'cd' => sub { $param::cachedisable = 1; },
 446     'p'  => sub {
 447         $param::pflag = 1;
 448         $param::build = 0;
 449     }
 450 );
 451 #4...........
 452         },
 453
 454         'align18.def' => {
 455             source => "align18",
 456             params => "def",
 457             expect => <<'#5...........',
 458 #align '&&'
 459 for ( $ENV{HTTP_USER_AGENT} ) {
 460     $page =
 461          /Mac/            && 'm/Macintrash.html'
 462       || /Win(dows)?NT/   && 'e/evilandrude.html'
 463       || /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html'
 464       || /Linux/          && 'l/Linux.html'
 465       || /HP-UX/          && 'h/HP-SUX.html'
 466       || /SunOS/          && 's/ScumOS.html'
 467       || 'a/AppendixB.html';
 468 }
 469 #5...........
 470         },
 471
 472         'kgb1.def' => {
 473             source => "kgb1",
 474             params => "def",
 475             expect => <<'#6...........',
 476 # a variety of line types for testing -kgb
 477 use strict;
 478 use Test;
 479 use Encode qw(from_to encode decode
 480   encode_utf8 decode_utf8
 481   find_encoding is_utf8);
 482 use charnames qw(greek);
 483 our $targetdir = "/usr/local/doc/HTML/Perl";
 484 local (
 485     $tocfile,   $loffile,   $lotfile,         $footfile,
 486     $citefile,  $idxfile,   $figure_captions, $table_captions,
 487     $footnotes, $citations, %font_size,       %index,
 488     %done,      $t_title,   $t_author,        $t_date,
 489     $t_address, $t_affil,   $changed
 490 );
 491 my @UNITCHECKs =
 492     B::unitcheck_av->isa("B::AV")
 493   ? B::unitcheck_av->ARRAY
 494   : ();
 495 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 496 my $dna    = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
 497 my $min    = 1;
 498 my $max    = length($dnasequence);
 499 my $T      = $G->_strongly_connected;
 500 my %R      = $T->vertex_roots;
 501 my @C;    # We're not calling the strongly_connected_components()
 502           # Do not separate this hanging side comment from previous
 503 my $G    = shift;
 504 my $exon = Bio::LiveSeq::Exon->new(
 505     -seq    => $dna,
 506     -start  => $min,
 507     -end    => $max,
 508     -strand => 1
 509 );
 510 my $octal_mode;
 511 my @inputs = (
 512     0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
 513     0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
 514 );
 515 my $impulse =
 516   ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
 517 my $r = q{
 518 pm_to_blib: $(TO_INST_PM)
 519 };
 520 my $regcomp_re =
 521   "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
 522 my $position = List::MoreUtils::firstidx {
 523     refaddr $_ == $key
 524 }
 525 my @exons      = ($exon);
 526 my $fastafile2 = "/tmp/tmpfastafile2";
 527 my $grepcut    = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-';  # grep/cut
 528 my $alignprogram =
 529 "/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
 530   ;                                                                   # ALIGN
 531 my $xml      = new Mioga::XML::Simple( forcearray => 1 );
 532 my $xml_tree = $xml->XMLin($skel_file);
 533 my $skel_name =
 534   ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
 535 my $grp = GroupGetValues( $conf->{dbh}, $group_id );
 536 my $adm_profile =
 537   ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
 538 my $harness = TAP::Harness->new(
 539     { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
 540 require File::Temp;
 541 require Time::HiRes;
 542 my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
 543 use File::Basename qw[dirname];
 544 my $dirname     = dirname($filename);
 545 my $CUT         = qr/\n=cut.*$EOP/;
 546 my $pod_or_DATA = qr/
 547               ^=(?:head[1-4]|item) .*? $CUT
 548             | ^=pod .*? $CUT
 549             | ^=for .*? $CUT
 550             | ^=begin .*? $CUT
 551             | ^__(DATA|END)__\r?\n.*
 552             /smx;
 553 require Cwd;
 554 ( my $boot = $self->{NAME} ) =~ s/:/_/g;
 555 doit(
 556     sub { @E::ISA = qw/F/ },
 557     sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
 558     sub { @C::ISA = qw//; @A::ISA = qw/K/ },
 559     sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
 560     sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
 561     sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
 562     sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
 563     sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
 564     return;
 565 );
 566 my %extractor_for = (
 567     quotelike => [ $ws, $variable,    $id, { MATCH => \&extract_quotelike } ],
 568     regex     => [ $ws, $pod_or_DATA, $id, $exql ],
 569     string    => [ $ws, $pod_or_DATA, $id, $exql ],
 570     code => [
 571         $ws,            { DONT_MATCH => $pod_or_DATA },
 572         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 573     ],
 574     code_no_comments => [
 575         { DONT_MATCH => $comment },
 576         $ncws,          { DONT_MATCH => $pod_or_DATA },
 577         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 578     ],
 579     executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
 580     executable_no_comments =>
 581       [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
 582     all => [ { MATCH => qr/(?s:.*)/ } ],
 583 );
 584 exit 1;
 585 #6...........
 586         },
 587
 588         'kgb1.kgb' => {
 589             source => "kgb1",
 590             params => "kgb",
 591             expect => <<'#7...........',
 592 # a variety of line types for testing -kgb
 593 use strict;
 594 use Test;
 595 use Encode qw(from_to encode decode
 596   encode_utf8 decode_utf8
 597   find_encoding is_utf8);
 598 use charnames qw(greek);
 599 our $targetdir = "/usr/local/doc/HTML/Perl";
 600 local (
 601     $tocfile,   $loffile,   $lotfile,         $footfile,
 602     $citefile,  $idxfile,   $figure_captions, $table_captions,
 603     $footnotes, $citations, %font_size,       %index,
 604     %done,      $t_title,   $t_author,        $t_date,
 605     $t_address, $t_affil,   $changed
 606 );
 607
 608 my @UNITCHECKs =
 609     B::unitcheck_av->isa("B::AV")
 610   ? B::unitcheck_av->ARRAY
 611   : ();
 612 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 613 my $dna    = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
 614 my $min    = 1;
 615 my $max    = length($dnasequence);
 616 my $T      = $G->_strongly_connected;
 617 my %R      = $T->vertex_roots;
 618 my @C;    # We're not calling the strongly_connected_components()
 619           # Do not separate this hanging side comment from previous
 620 my $G    = shift;
 621 my $exon = Bio::LiveSeq::Exon->new(
 622     -seq    => $dna,
 623     -start  => $min,
 624     -end    => $max,
 625     -strand => 1
 626 );
 627 my $octal_mode;
 628 my @inputs = (
 629     0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
 630     0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
 631 );
 632 my $impulse =
 633   ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
 634 my $r = q{
 635 pm_to_blib: $(TO_INST_PM)
 636 };
 637 my $regcomp_re =
 638   "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
 639 my $position = List::MoreUtils::firstidx {
 640     refaddr $_ == $key
 641 }
 642 my @exons      = ($exon);
 643 my $fastafile2 = "/tmp/tmpfastafile2";
 644 my $grepcut    = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-';  # grep/cut
 645 my $alignprogram =
 646 "/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
 647   ;                                                                   # ALIGN
 648 my $xml      = new Mioga::XML::Simple( forcearray => 1 );
 649 my $xml_tree = $xml->XMLin($skel_file);
 650 my $skel_name =
 651   ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
 652 my $grp = GroupGetValues( $conf->{dbh}, $group_id );
 653 my $adm_profile =
 654   ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
 655 my $harness = TAP::Harness->new(
 656     { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
 657
 658 require File::Temp;
 659 require Time::HiRes;
 660 my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
 661 use File::Basename qw[dirname];
 662 my $dirname     = dirname($filename);
 663 my $CUT         = qr/\n=cut.*$EOP/;
 664 my $pod_or_DATA = qr/
 665               ^=(?:head[1-4]|item) .*? $CUT
 666             | ^=pod .*? $CUT
 667             | ^=for .*? $CUT
 668             | ^=begin .*? $CUT
 669             | ^__(DATA|END)__\r?\n.*
 670             /smx;
 671 require Cwd;
 672
 673 ( my $boot = $self->{NAME} ) =~ s/:/_/g;
 674 doit(
 675     sub { @E::ISA = qw/F/ },
 676     sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
 677     sub { @C::ISA = qw//; @A::ISA = qw/K/ },
 678     sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
 679     sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
 680     sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
 681     sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
 682     sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
 683     return;
 684 );
 685 my %extractor_for = (
 686     quotelike => [ $ws, $variable,    $id, { MATCH => \&extract_quotelike } ],
 687     regex     => [ $ws, $pod_or_DATA, $id, $exql ],
 688     string    => [ $ws, $pod_or_DATA, $id, $exql ],
 689     code => [
 690         $ws,            { DONT_MATCH => $pod_or_DATA },
 691         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 692     ],
 693     code_no_comments => [
 694         { DONT_MATCH => $comment },
 695         $ncws,          { DONT_MATCH => $pod_or_DATA },
 696         $variable, $id, { DONT_MATCH => \&extract_quotelike }
 697     ],
 698     executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
 699     executable_no_comments =>
 700       [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
 701     all => [ { MATCH => qr/(?s:.*)/ } ],
 702 );
 703 exit 1;
 704 #7...........
 705         },
 706
 707         'kgb2.def' => {
 708             source => "kgb2",
 709             params => "def",
 710             expect => <<'#8...........',
 711 # with -kgb, do no break after last my
 712 sub next_sibling {
 713     my $self     = shift;
 714     my $parent   = $_PARENT{ refaddr $self} or return '';
 715     my $key      = refaddr $self;
 716     my $elements = $parent->{children};
 717     my $position = List::MoreUtils::firstidx {
 718         refaddr $_ == $key
 719     }
 720     @$elements;
 721     $elements->[ $position + 1 ] || '';
 722 }
 723
 724 #8...........
 725         },
 726
 727         'kgb2.kgb' => {
 728             source => "kgb2",
 729             params => "kgb",
 730             expect => <<'#9...........',
 731 # with -kgb, do no break after last my
 732 sub next_sibling {
 733
 734     my $self     = shift;
 735     my $parent   = $_PARENT{ refaddr $self} or return '';
 736     my $key      = refaddr $self;
 737     my $elements = $parent->{children};
 738     my $position = List::MoreUtils::firstidx {
 739         refaddr $_ == $key
 740     }
 741     @$elements;
 742     $elements->[ $position + 1 ] || '';
 743 }
 744
 745 #9...........
 746         },
 747
 748         'kgb3.def' => {
 749             source => "kgb3",
 750             params => "def",
 751             expect => <<'#10...........',
 752 #!/usr/bin/perl -w
 753 use strict;    # with -kgb, no break after hash bang
 754 our ( @Changed, $TAP );    # break after isolated 'our'
 755 use File::Compare;
 756 use Symbol;
 757 use Text::Wrap();
 758 use Text::Warp();
 759 use Blast::IPS::MathUtils qw(
 760   set_interpolation_points
 761   table_row_interpolation
 762   two_point_interpolation
 763   );                       # with -kgb, break around isolated 'local' below
 764 use Text::Warp();
 765 local ($delta2print) =
 766   ( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
 767 print "break before this line\n";
 768 #10...........
 769         },
 770
 771         'kgb3.kgb' => {
 772             source => "kgb3",
 773             params => "kgb",
 774             expect => <<'#11...........',
 775 #!/usr/bin/perl -w
 776 use strict;    # with -kgb, no break after hash bang
 777 our ( @Changed, $TAP );    # break after isolated 'our'
 778
 779 use File::Compare;
 780 use Symbol;
 781 use Text::Wrap();
 782 use Text::Warp();
 783 use Blast::IPS::MathUtils qw(
 784   set_interpolation_points
 785   table_row_interpolation
 786   two_point_interpolation
 787   );                       # with -kgb, break around isolated 'local' below
 788 use Text::Warp();
 789
 790 local ($delta2print) =
 791   ( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
 792
 793 print "break before this line\n";
 794 #11...........
 795         },
 796
 797         'kgb4.def' => {
 798             source => "kgb4",
 799             params => "def",
 800             expect => <<'#12...........',
 801 print "hello";    # with -kgb, break after this line
 802 use strict;
 803 use warnings;
 804 use Test::More tests => 1;
 805 use Pod::Simple::XHTML;
 806 my $c = <<EOF;
 807 =head1 Documentation
 808 The keyword group dies here
 809 Do not put a blank line in this here-doc
 810 EOF
 811 my $d = $c . "=cut\n";
 812 exit 1;
 813 _END_
 814 #12...........
 815         },
 816
 817         'kgb4.kgb' => {
 818             source => "kgb4",
 819             params => "kgb",
 820             expect => <<'#13...........',
 821 print "hello";    # with -kgb, break after this line
 822
 823 use strict;
 824 use warnings;
 825 use Test::More tests => 1;
 826 use Pod::Simple::XHTML;
 827 my $c = <<EOF;
 828 =head1 Documentation
 829 The keyword group dies here
 830 Do not put a blank line in this here-doc
 831 EOF
 832 my $d = $c . "=cut\n";
 833 exit 1;
 834 _END_
 835 #13...........
 836         },
 837
 838         'kgb5.def' => {
 839             source => "kgb5",
 840             params => "def",
 841             expect => <<'#14...........',
 842 # with -kgb, do not put blank in ternary
 843 print "Starting\n";    # with -kgb, break after this line
 844 my $A = "1";
 845 my $B = "0";
 846 my $C = "1";
 847 my $D = "1";
 848 my $result =
 849     $A
 850   ? $B
 851       ? $C
 852           ? "+A +B +C"
 853           : "+A +B -C"
 854       : "+A -B"
 855   : "-A";
 856 my $F = "0";
 857 print "with -kgb, put blank above this line; result=$result\n";
 858 #14...........
 859         },
 860
 861         'kgb5.kgb' => {
 862             source => "kgb5",
 863             params => "kgb",
 864             expect => <<'#15...........',
 865 # with -kgb, do not put blank in ternary
 866 print "Starting\n";    # with -kgb, break after this line
 867
 868 my $A = "1";
 869 my $B = "0";
 870 my $C = "1";
 871 my $D = "1";
 872 my $result =
 873     $A
 874   ? $B
 875       ? $C
 876           ? "+A +B +C"
 877           : "+A +B -C"
 878       : "+A -B"
 879   : "-A";
 880 my $F = "0";
 881 print "with -kgb, put blank above this line; result=$result\n";
 882 #15...........
 883         },
 884
 885         'kgbd.def' => {
 886             source => "kgbd",
 887             params => "def",
 888             expect => <<'#16...........',
 889 package A1::B2;
 890
 891 use strict;
 892
 893 require Exporter;
 894 use A1::Context;
 895
 896 use A1::Database;
 897 use A1::Bibliotek;
 898 use A1::Author;
 899 use A1::Title;
 900
 901 use vars qw($VERSION @ISA @EXPORT);
 902 $VERSION = 0.01;
 903 #16...........
 904         },
 905
 906         'kgbd.kgbd' => {
 907             source => "kgbd",
 908             params => "kgbd",
 909             expect => <<'#17...........',
 910 package A1::B2;
 911
 912 use strict;
 913 require Exporter;
 914
 915 use A1::Context;
 916 use A1::Database;
 917 use A1::Bibliotek;
 918 use A1::Author;
 919 use A1::Title;
 920 use vars qw($VERSION @ISA @EXPORT);
 921
 922 $VERSION = 0.01;
 923 #17...........
 924         },
 925
 926         'kgb_tight.def' => {
 927             source => "kgb_tight",
 928             params => "def",
 929             expect => <<'#18...........',
 930 # a variety of line types for testing -kgb
 931 use strict;
 932 use Test;
 933 use Encode qw(from_to encode decode
 934   encode_utf8 decode_utf8
 935   find_encoding is_utf8);
 936
 937 use charnames qw(greek);
 938 our $targetdir = "/usr/local/doc/HTML/Perl";
 939
 940 local (
 941     $tocfile,   $loffile,   $lotfile,         $footfile,
 942     $citefile,  $idxfile,   $figure_captions, $table_captions,
 943     $footnotes, $citations, %font_size,       %index,
 944     %done,      $t_title,   $t_author,        $t_date,
 945     $t_address, $t_affil,   $changed
 946 );
 947 my @UNITCHECKs =
 948     B::unitcheck_av->isa("B::AV")
 949   ? B::unitcheck_av->ARRAY
 950   : ();
 951
 952 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
 953 my $dna    = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
 954 my $min    = 1;
 955 my $max    = length($dnasequence);
 956 my $T      = $G->_strongly_connected;
 957
 958 my %R = $T->vertex_roots;
 959 my @C;    # We're not calling the strongly_connected_components()
 960           # Do not separate this hanging side comment from previous
 961
 962 my $G = shift;
 963
 964 my $exon = Bio::LiveSeq::Exon->new(
 965     -seq    => $dna,
 966     -start  => $min,
 967     -end    => $max,
 968     -strand => 1
 969 );
 970 my @inputs = (
 971     0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
 972     0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
 973 );
 974 my $impulse =
 975   ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
 976 my $r = q{
 977 pm_to_blib: $(TO_INST_PM)
 978 };
 979 my $regcomp_re =
 980   "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
 981 my $position = List::MoreUtils::firstidx {
 982     refaddr $_ == $key
 983 }
 984
 985 my $alignprogram =
 986 "/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
 987   ;    # ALIGN
 988 my $skel_name =
 989   ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
 990 my $grp = GroupGetValues( $conf->{dbh}, $group_id );
 991
 992 my $adm_profile =
 993   ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
 994 my $harness = TAP::Harness->new(
 995     { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
 996 require File::Temp;
 997
 998 require Time::HiRes;
 999
1000 my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
1001 use File::Basename qw[dirname];
1002 my $dirname = dirname($filename);
1003 my $CUT     = qr/\n=cut.*$EOP/;
1004
1005 my $pod_or_DATA = qr/
1006               ^=(?:head[1-4]|item) .*? $CUT
1007             | ^=pod .*? $CUT
1008             | ^=for .*? $CUT
1009             | ^=begin .*? $CUT
1010             | ^__(DATA|END)__\r?\n.*
1011             /smx;
1012
1013 require Cwd;
1014 print "continuing\n";
1015 exit 1;
1016 #18...........
1017         },
1018
1019         'gnu5.def' => {
1020             source => "gnu5",
1021             params => "def",
1022             expect => <<'#19...........',
1023         # side comments limit gnu type formatting with l=80; note extra comma
1024         push @tests, [
1025             "Lowest code point requiring 13 bytes to represent",    # 2**36
1026             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
1027             ($::is64bit) ? 0x1000000000 : -1,    # overflows on 32bit
1028           ],
1029           ;
1030 #19...........
1031         },
1032     };
1033
1034     my $ntests = 0 + keys %{$rtests};
1035     plan tests => $ntests;
1036 }
1037
1038 ###############
1039 # EXECUTE TESTS
1040 ###############
1041
1042 foreach my $key ( sort keys %{$rtests} ) {
1043     my $output;
1044     my $sname  = $rtests->{$key}->{source};
1045     my $expect = $rtests->{$key}->{expect};
1046     my $pname  = $rtests->{$key}->{params};
1047     my $source = $rsources->{$sname};
1048     my $params = defined($pname) ? $rparams->{$pname} : "";
1049     my $stderr_string;
1050     my $errorfile_string;
1051     my $err = Perl::Tidy::perltidy(
1052         source      => \$source,
1053         destination => \$output,
1054         perltidyrc  => \$params,
1055         argv        => '',             # for safety; hide any ARGV from perltidy
1056         stderr      => \$stderr_string,
1057         errorfile => \$errorfile_string,    # not used when -se flag is set
1058     );
1059     if ( $err || $stderr_string || $errorfile_string ) {
1060         if ($err) {
1061             print STDERR
1062 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
1063             ok( !$err );
1064         }
1065         if ($stderr_string) {
1066             print STDERR "---------------------\n";
1067             print STDERR "<<STDERR>>\n$stderr_string\n";
1068             print STDERR "---------------------\n";
1069             print STDERR
1070 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
1071             ok( !$stderr_string );
1072         }
1073         if ($errorfile_string) {
1074             print STDERR "---------------------\n";
1075             print STDERR "<<.ERR file>>\n$errorfile_string\n";
1076             print STDERR "---------------------\n";
1077             print STDERR
1078 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
1079             ok( !$errorfile_string );
1080         }
1081     }
1082     else {
1083         ok( $output, $expect );
1084     }
1085 }