"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/t/snippets14.t" (7 Jan 2020, 30829 Bytes) of package /linux/misc/Perl-Tidy-20200110.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "snippets14.t": 20191203_vs_20200110.

    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 }