When this type of testing was begun, several dozen problems were quickly
identified and fixed. The most common problem was that an uninitialized
variable was referenced in some way. It has been some time since a new problem
-was detected with these scripts, but it is important to periodically run these
+was detected with these scripts, but it is important to run these
tests periodically, and always before a release, because new coding and new
parameters may introduce bugs.
## Prepare a temporary directory
First collect a large number (say 50 or more) of arbitrary perl scripts in a
-single directory. These files can also contain arbitrary other files, such as
+single directory. You may also include other arbitrary files, such as
text or html files.
Then create a temporary sub directory and enter it, say
random set of perltidy parameters). The number of random profiles is set to 50
but I sometimes increase it to 100 or 200. Every input file will be run
against every random profile, so this can significantly increase the total run
-time. The main menu looks like this (I am not sure if this will format correctly):
+time. The main menu looks like this:
```
R - Read a config file
########################################
$category = 13; # Debugging
########################################
-## $add_option->( 'DIAGNOSTICS', 'I', '!' );
- $add_option->( 'DEBUG', 'D', '!' );
- $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
- $add_option->( 'dump-defaults', 'ddf', '!' );
- $add_option->( 'dump-long-names', 'dln', '!' );
- $add_option->( 'dump-options', 'dop', '!' );
- $add_option->( 'dump-profile', 'dpro', '!' );
- $add_option->( 'dump-short-names', 'dsn', '!' );
- $add_option->( 'dump-token-types', 'dtt', '!' );
- $add_option->( 'dump-want-left-space', 'dwls', '!' );
- $add_option->( 'dump-want-right-space', 'dwrs', '!' );
- $add_option->( 'fuzzy-line-length', 'fll', '!' );
- $add_option->( 'help', 'h', '' );
+ $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
+ $add_option->( 'DEBUG', 'D', '!' );
+ $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
+ $add_option->( 'dump-defaults', 'ddf', '!' );
+ $add_option->( 'dump-long-names', 'dln', '!' );
+ $add_option->( 'dump-options', 'dop', '!' );
+ $add_option->( 'dump-profile', 'dpro', '!' );
+ $add_option->( 'dump-short-names', 'dsn', '!' );
+ $add_option->( 'dump-token-types', 'dtt', '!' );
+ $add_option->( 'dump-want-left-space', 'dwls', '!' );
+ $add_option->( 'dump-want-right-space', 'dwrs', '!' );
+ $add_option->( 'fuzzy-line-length', 'fll', '!' );
+ $add_option->( 'help', 'h', '' );
$add_option->( 'short-concatenation-item-length', 'scl', '=i' );
$add_option->( 'show-options', 'opt', '!' );
$add_option->( 'timestamp', 'ts', '!' );
# CODE SECTION 2: Some Basic Utilities
######################################
-sub check_keys {
- my ( $rtest, $rvalid, $msg, $exact_match ) = @_;
-
- # Check the keys of a hash:
- # $rtest = ref to hash to test
- # $rvalid = ref to hash with valid keys
-
- # $msg = a message to write in case of error
- # $exact_match defines the type of check:
- # = false: test hash must not have unknown key
- # = true: test hash must have exactly same keys as known hash
- my @unknown_keys =
- grep { !exists $rvalid->{$_} } keys %{$rtest};
- my @missing_keys =
- grep { !exists $rtest->{$_} } keys %{$rvalid};
- my $error = @unknown_keys;
- if ($exact_match) { $error ||= @missing_keys }
- if ($error) {
- local $" = ')(';
- my @expected_keys = sort keys %{$rvalid};
- @unknown_keys = sort @unknown_keys;
- Die(<<EOM);
-------------------------------------------------------------------------
-Program error detected checking hash keys
-Message is: '$msg'
-Expected keys: (@expected_keys)
-Unknown key(s): (@unknown_keys)
-Missing key(s): (@missing_keys)
-------------------------------------------------------------------------
-EOM
- }
- return;
-}
-
{ ## begin closure for logger routines
my $logger_object;
foreach my $item ( @{$rKrange_code_without_comments} ) {
my ( $Kfirst, $Klast ) = @{$item};
- my $typeb = $rLL->[$Kfirst]->[_TYPE_];
- if ( $keep_break_before_type{$typeb} ) {
+ my $type_first = $rLL->[$Kfirst]->[_TYPE_];
+ if ( $keep_break_before_type{$type_first} ) {
$rbreak_before_Kfirst->{$Kfirst} = 1;
}
- my $typee = $rLL->[$Klast]->[_TYPE_];
- if ( $keep_break_after_type{$typee} ) {
+ my $type_last = $rLL->[$Klast]->[_TYPE_];
+ if ( $keep_break_after_type{$type_last} ) {
$rbreak_after_Klast->{$Klast} = 1;
}
}
# Note that weld_nested_containers() changes the _LEVEL_ values, so
# weld_cuddled_blocks must use the _TRUE_LEVEL_ values instead.
- # Here is a good test case to Be sure that both cuddling and welding
+ # Here is a good test case to be sure that both cuddling and welding
# are working and not interfering with each other: <<snippets/ce_wn1.in>>
# perltidy -wn -ce
}
sub cumulative_length_after_K {
+
+ # NOTE: This routine not currently called; could be deleted
my ( $self, $KK ) = @_;
my $rLL = $self->[_rLL_];
return $rLL->[$KK]->[_CUMULATIVE_LENGTH_];
@unmatched_closing_indexes_in_this_batch;
}
- sub comma_arrow_count {
- my $seqno = shift;
- return $comma_arrow_count{$seqno};
- }
-
sub match_opening_and_closing_tokens {
# Match up indexes of opening and closing braces, etc, in this batch.
return;
}
-sub mate_index_to_go {
- my ( $self, $i ) = @_;
-
- # NOTE: This works but is too inefficient, but is retained for info.
-
- # Return the matching index of a container or ternary pair
- # This is equivalent to the array @mate_index_to_go
- my $K = $K_to_go[$i];
- my $K_mate = $self->K_mate_index($K);
- my $i_mate = -1;
- if ( defined($K_mate) ) {
- $i_mate = $i + ( $K_mate - $K );
- if ( $i_mate < 0 || $i_mate > $max_index_to_go ) {
- $i_mate = -1;
- }
- }
- my $i_mate_alt = $mate_index_to_go[$i];
-
- # FIXME: Old Debug code which can be removed eventually
- if ( 0 && $i_mate_alt != $i_mate ) {
- my $tok = $tokens_to_go[$i];
- my $type = $types_to_go[$i];
- my $tok_mate = '*';
- my $type_mate = '*';
- if ( $i_mate >= 0 && $i_mate <= $max_index_to_go ) {
- $tok_mate = $tokens_to_go[$i_mate];
- $type_mate = $types_to_go[$i_mate];
- }
- my $seq = $type_sequence_to_go[$i];
- my $file = get_input_stream_name();
-
- Warn(
-"mate_index: file '$file': i=$i, imate=$i_mate, should be $i_mate_alt, K=$K, K_mate=$K_mate\ntype=$type, tok=$tok, seq=$seq, max=$max_index_to_go, tok_mate=$tok_mate, type_mate=$type_mate"
- );
- }
- return $i_mate;
-}
-
-sub K_mate_index {
-
- # Given the index K of an opening or closing container, or ?/: ternary pair,
- # return the index K of the other member of the pair.
- my ( $self, $K ) = @_;
- return unless defined($K);
- my $rLL = $self->[_rLL_];
- my $seqno = $rLL->[$K]->[_TYPE_SEQUENCE_];
- return unless ($seqno);
-
- my $K_opening = $self->[_K_opening_container_]->{$seqno};
- if ( defined($K_opening) ) {
- if ( $K != $K_opening ) { return $K_opening }
- return $self->[_K_closing_container_]->{$seqno};
- }
-
- $K_opening = $self->[_K_opening_ternary_]->{$seqno};
- if ( defined($K_opening) ) {
- if ( $K != $K_opening ) { return $K_opening }
- return $self->[_K_closing_ternary_]->{$seqno};
- }
- return;
-}
-
{ ## begin closure make_alignment_patterns
my %block_type_map;
projects / perltidy.git / commitdiff