# display the version of perl - just for possible manual verification
- run: perl -V
- # added to avoid problems with line ending conversions in git #83 update
- - run: |
- git config --global core.autocrlf false
- git config --global core.eol lf
-
# Instal the dependencies declared by the module ...
# There are no deps for perltidy, but this would be the command:
# - run: cpanm --installdeps .
=item B<Keeping old breakpoints at specific token types>
-Two command line parameters provide detailed control over whether
-perltidy should keep an old line break before or after a specific
-token type:
+It is possible to override the choice of line breaks made by perltidy, and
+force it to follow certain line breaks in the input stream, with these two
+parameters:
B<-kbb=s> or B<--keep-old-breakpoints-before=s>, and
...;
};
+For the container tokens '{', '[' and '(' and, their closing counterparts, use the token symbol. Thus,
+the command to keep a break after all opening parens is:
+
+ perltidy -kba='('
+
+It is possible to be more specific in matching parentheses by preceding them
+with a letter. The possible letters are 'k', 'K', 'f', 'F', 'w', and 'W', with
+these meanings (these are the same as used in the
+B<--weld-nested-exclusion-list> and B<--line-up-parentheses-exclusion-list>
+parameters):
+
+ 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+ 'K' matches if 'k' does not, meaning that the previous token is not a keyword.
+ 'f' matches if the previous token is a function other than a keyword.
+ 'F' matches if 'f' does not.
+ 'w' matches if either 'k' or 'f' match.
+ 'W' matches if 'w' does not.
+
+So for example the the following parameter will keep breaks after opening function call
+parens:
+
+ perltidy -kba='f('
+
+B<NOTE>: To match all opening curly braces, and no other opening tokens, please
+prefix the brace it with an asterisk, like this: '*{'. Otherwise a warning
+message will occur. This is necessary to avoid problems while the input scheme
+is being updated and generalized. A single bare curly brace previously matched
+all container tokens, and tentatively still does. Likewise, to match all
+closing curly braces, and no other closing tokens, use '*}'.
+
=item B<-iob>, B<--ignore-old-breakpoints>
Use this flag to tell perltidy to ignore existing line breaks to the
'?' => ':',
);
- # note any requested old line breaks to keep
- %keep_break_before_type = ();
- %keep_break_after_type = ();
- if ( !$rOpts->{'ignore-old-breakpoints'} ) {
+ if ( $rOpts->{'ignore-old-breakpoints'} ) {
- # FIXME: could check for valid types here.
- # Invalid types are harmless but probably not intended.
- my @types;
- @types = ( split_words( $rOpts->{'keep-old-breakpoints-before'} ) );
- @keep_break_before_type{@types} = (1) x scalar(@types);
- @types = ( split_words( $rOpts->{'keep-old-breakpoints-after'} ) );
- @keep_break_after_type{@types} = (1) x scalar(@types);
- }
- else {
+ my @conflicts;
if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
- Warn("Conflicting parameters: -iob and -bom; -bom will be ignored\n"
- );
$rOpts->{'break-at-old-method-breakpoints'} = 0;
+ push @conflicts, '--break-at-old-method-breakpoints (-bom)';
}
if ( $rOpts->{'break-at-old-comma-breakpoints'} ) {
- Warn("Conflicting parameters: -iob and -boc; -boc will be ignored\n"
- );
$rOpts->{'break-at-old-comma-breakpoints'} = 0;
+ push @conflicts, '--break-at-old-comma-breakpoints (-boc)';
}
if ( $rOpts->{'break-at-old-semicolon-breakpoints'} ) {
- Warn("Conflicting parameters: -iob and -bos; -bos will be ignored\n"
- );
$rOpts->{'break-at-old-semicolon-breakpoints'} = 0;
+ push @conflicts, '--break-at-old-semicolon-breakpoints (-bos)';
}
if ( $rOpts->{'keep-old-breakpoints-before'} ) {
- Warn("Conflicting parameters: -iob and -kbb; -kbb will be ignored\n"
- );
$rOpts->{'keep-old-breakpoints-before'} = "";
+ push @conflicts, '--keep-old-breakpoints-before (-kbb)';
}
if ( $rOpts->{'keep-old-breakpoints-after'} ) {
- Warn("Conflicting parameters: -iob and -kba; -kba will be ignored\n"
- );
$rOpts->{'keep-old-breakpoints-after'} = "";
+ push @conflicts, '--keep-old-breakpoints-after (-kba)';
+ }
+
+ if (@conflicts) {
+ my $msg = join( "\n ",
+" Conflict: These conflicts with --ignore-old-breakponts (-iob) will be turned off:",
+ @conflicts )
+ . "\n";
+ Warn($msg);
}
# Note: These additional parameters are made inactive by -iob.
$rOpts->{'break-at-old-attribute-breakpoints'} = 0;
}
+ %keep_break_before_type = ();
+ initialize_keep_old_breakpoints( $rOpts->{'keep-old-breakpoints-before'},
+ 'kbb', \%keep_break_before_type );
+
+ %keep_break_after_type = ();
+ initialize_keep_old_breakpoints( $rOpts->{'keep-old-breakpoints-after'},
+ 'kba', \%keep_break_after_type );
+
#------------------------------------------------------------
# Make global vars for frequently used options for efficiency
#------------------------------------------------------------
return;
}
+use constant DEBUG_KB => 0;
+
+sub initialize_keep_old_breakpoints {
+ my ( $str, $short_name, $rkeep_break_hash ) = @_;
+ return unless $str;
+
+ my %flags = ();
+ my @list = split_words($str);
+
+ # - pull out any any leading container letter code, like 'f(
+ map { s/^ ([\w\*]) ( [ [\{\(\[\}\)\] ] ) $/$2/x; $flags{$2} .= $1 if ($1) }
+ @list;
+
+ @{$rkeep_break_hash}{@list} = (1) x scalar(@list);
+
+ foreach my $key ( keys %flags ) {
+ my $flag = $flags{$key};
+
+ if ( length($flag) != 1 ) {
+ Warn(<<EOM);
+Multiple entries given for '$key' in '$short_name'
+EOM
+ }
+ elsif ( ( $key eq '(' || $key eq ')' ) && $flag !~ /^[kKfFwW\*]$/ ) {
+ Warn(<<EOM);
+Unknown flag '$flag' given for '$key' in '$short_name'
+EOM
+ }
+ elsif ( ( $key eq '}' || $key eq '}' ) && $flag !~ /^[bB\*]$/ ) {
+ Warn(<<EOM);
+Unknown flag '$flag' given for '$key' in '$short_name'
+EOM
+ }
+
+ $rkeep_break_hash->{$key} = $flag;
+ }
+
+ # Temporary patch and warning during changeover from using type to token for
+ # containers . This can be eliminated after one or two future releases.
+ if ( $rkeep_break_hash->{'{'}
+ && $rkeep_break_hash->{'{'} eq '1'
+ && !$rkeep_break_hash->{'('}
+ && !$rkeep_break_hash->{'['} )
+ {
+ $rkeep_break_hash->{'('} = 1;
+ $rkeep_break_hash->{'['} = 1;
+ Warn(<<EOM);
+Sorry, but the format for the -kbb and -kba flags for container tokens is changing a
+little to allow generalization and for consistency with other parameters. You entered '{'
+which currently still matches '{' '(' and '[', but in the future it will only match '{'.
+To prevent this message please do one of the following:
+ use '{ ( [' if you want to match all opening containers, or
+ use '(' or '[' to match just those containers, or
+ use '*{' to match only opening braces
+EOM
+ }
+
+ if ( $rkeep_break_hash->{'}'}
+ && $rkeep_break_hash->{'}'} eq '1'
+ && !$rkeep_break_hash->{')'}
+ && !$rkeep_break_hash->{']'} )
+ {
+ $rkeep_break_hash->{'('} = 1;
+ $rkeep_break_hash->{'['} = 1;
+ Warn(<<EOM);
+Sorry, but the format for the -kbb and -kba flags for container tokens is changing a
+little to allow generalization and for consistency with other parameters. You entered '}'
+which currently still matches '}' ')' and ']', but in the future it will only match '}'.
+To prevent this message please do one of the following:
+ use '} ) ]' if you want to match all closing containers, or
+ use ')' or ']' to match just those containers, or
+ use '*}' to match only closing braces
+EOM
+ }
+
+ if ( DEBUG_KB && @list ) {
+ my @tmp = %flags;
+ print <<EOM;
+
+DEBUG_KB -$short_name flag: $str
+final keys: @list
+special flags: @tmp
+EOM
+
+ }
+
+ return;
+
+}
+
sub initialize_whitespace_hashes {
# This is called once before formatting begins to initialize these global
return unless ( %keep_break_before_type || %keep_break_after_type );
- foreach my $item ( @{$rKrange_code_without_comments} ) {
- my ( $Kfirst, $Klast ) = @{$item};
+ my $check_for_break = sub {
+ my ( $KK, $rkeep_break_hash, $rbreak_hash ) = @_;
+ my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
- my $type_first = $rLL->[$Kfirst]->[_TYPE_];
- if ( $keep_break_before_type{$type_first} ) {
- $rbreak_before_Kfirst->{$Kfirst} = 1;
+ # non-container tokens use the type as the key
+ if ( !$seqno ) {
+ my $type = $rLL->[$KK]->[_TYPE_];
+ if ( $rkeep_break_hash->{$type} ) {
+ $rbreak_hash->{$KK} = 1;
+ }
}
- my $type_last = $rLL->[$Klast]->[_TYPE_];
- if ( $keep_break_after_type{$type_last} ) {
- $rbreak_after_Klast->{$Klast} = 1;
+ # container tokens use the token as the key
+ else {
+ my $token = $rLL->[$KK]->[_TOKEN_];
+ my $flag = $rkeep_break_hash->{$token};
+ if ($flag) {
+
+ my $match = $flag eq '1' || $flag eq '*';
+
+ # check for special matching codes
+ if ( !$match ) {
+ if ( $token eq '(' || $token eq ')' ) {
+ $match = $self->match_paren_flag( $KK, $flag );
+ }
+ elsif ( $token eq '{' || $token eq '}' ) {
+
+ # codes for brace types could be expanded in the future
+ my $block_type =
+ $self->[_rblock_type_of_seqno_]->{$seqno};
+ if ( $flag eq 'b' ) { $match = $block_type }
+ elsif ( $flag eq 'B' ) { $match = !$block_type }
+ else {
+ # unknown code - no match
+ }
+ }
+ }
+ $rbreak_hash->{$KK} = 1 if ($match);
+ }
}
+ };
+
+ foreach my $item ( @{$rKrange_code_without_comments} ) {
+ my ( $Kfirst, $Klast ) = @{$item};
+ $check_for_break->(
+ $Kfirst, \%keep_break_before_type, $rbreak_before_Kfirst
+ );
+ $check_for_break->(
+ $Klast, \%keep_break_after_type, $rbreak_after_Klast
+ );
}
return;
}
return 0 unless ( defined($flag) );
return 0 if $flag eq '0';
+ return 1 if $flag eq '1';
return 1 if $flag eq '*';
return 0 unless ( defined($KK) );
my $rLL = $self->[_rLL_];
my $rtoken_vars = $rLL->[$KK];
+ my $seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
+ return 0 unless ($seqno);
+ my $token = $rtoken_vars->[_TOKEN_];
+ my $K_opening = $KK;
+ if ( !$is_opening_token{$token} ) {
+ $K_opening = $self->[_K_opening_container_]->{$seqno};
+ }
+ return unless ( defined($K_opening) );
+
my ( $is_f, $is_k, $is_w );
- my $Kp = $self->K_previous_nonblank($KK);
+ my $Kp = $self->K_previous_nonblank($K_opening);
if ( defined($Kp) ) {
- my $seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
my $type_p = $rLL->[$Kp]->[_TYPE_];
# keyword?
--- /dev/null
+use strict;
+use warnings;
+use utf8;
+
+use FindBin qw($Bin);
+use File::Temp qw(tempfile);
+use Test::More;
+
+BEGIN { unshift @INC, "./" }
+use Perl::Tidy;
+
+# This is off pending a good resolution of the problem with line endings.
+
+# This tests the -eos (--encode-output-strings) which was added for issue
+# git #83 to fix an issue with tidyall.
+
+# The test file has no tidying needs but is UTF-8 encoded, so all passes
+# through perltidy should read/write identical contents (previously only
+# file test behaved correctly)
+
+# This attempted fix did not work:
+# The original version did hex compares of source and destination streams. To
+# just test the -eos flag, and avoid line ending issues, this version does
+# line-by-line hex tests on chomped lines.
+
+plan( tests => 6 );
+
+test_all();
+
+sub test_all {
+ my $test_file = "$Bin/testwide-passthrough.pl.src";
+ test_file2file($test_file);
+ test_scalar2scalar($test_file);
+ test_scalararray2scalararray($test_file);
+}
+
+sub test_file2file {
+ my $test_file = shift;
+
+ my $tmp_file = File::Temp->new( TMPDIR => 1 );
+
+ my $source = $test_file;
+ my $destination = $tmp_file->filename();
+
+ note("Testing file2file: '$source' => '$destination'\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_str = slurp_raw($source);
+ my $destination_str = slurp_raw($destination);
+
+ my $source_hex = unpack( 'H*', $source_str );
+ my $destination_hex = unpack( 'H*', $destination_str );
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+
+ ok($source_hex eq $destination_hex, 'file content compare');
+}
+
+sub test_scalar2scalar {
+ my $testfile = shift;
+
+ my $source = slurp_raw($testfile);
+ my $destination;
+
+ note("Testing scalar2scalar\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos',
+ source => \$source,
+ destination => \$destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_hex = unpack( 'H*', $source );
+ my $destination_hex = unpack( 'H*', $destination );
+
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+ ok($source_hex eq $destination_hex, 'scalar content compare');
+}
+
+sub test_scalararray2scalararray {
+ my $testfile = shift;
+
+ my $source = [ lines_raw($testfile) ];
+ my $destination = [];
+
+ note("Testing scalararray2scalararray\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_str = join( "", @$source );
+ my $destination_str = join( "", @$destination );
+
+ my $source_hex = unpack( 'H*', $source_str );
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+ ok($source_hex eq $destination_hex, 'scalararray content compare');
+}
+
+sub slurp_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ local $/;
+ my $contents = <TMP>;
+ close(TMP);
+
+ return $contents;
+}
+
+sub lines_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ my @contents = <TMP>;
+ close(TMP);
+
+ return @contents;
+}
+
+sub hex_compare_by_lines {
+ my ( $source_str, $destination_str ) = @_;
+
+ my @source = split /^/m, $source_str;
+ my @destination = split /^/m, $destination_str;
+
+ while (@source) {
+ my $ss = pop(@source);
+ my $dd = pop(@destination);
+ chomp $ss;
+ chomp $dd;
+ $ss = unpack( 'H*', $ss );
+ $dd = unpack( 'H*', $dd );
+ last if $ss ne $dd;
+ }
+ return !@source && !@destination;
+}
+
+++ /dev/null
-use strict;
-use warnings;
-use utf8;
-
-use FindBin qw($Bin);
-use File::Temp qw(tempfile);
-use Test::More;
-
-BEGIN { unshift @INC, "./" }
-use Perl::Tidy;
-
-# This is off pending a good resolution of the problem with line endings.
-
-# This tests the -eos (--encode-output-strings) which was added for issue
-# git #83 to fix an issue with tidyall.
-
-# The test file has no tidying needs but is UTF-8 encoded, so all passes
-# through perltidy should read/write identical contents (previously only
-# file test behaved correctly)
-
-# This attempted fix did not work:
-# The original version did hex compares of source and destination streams. To
-# just test the -eos flag, and avoid line ending issues, this version does
-# line-by-line hex tests on chomped lines.
-
-plan( tests => 6 );
-
-test_all();
-
-sub test_all {
- my $test_file = "$Bin/testwide-passthrough.pl.src";
- test_file2file($test_file);
- test_scalar2scalar($test_file);
- test_scalararray2scalararray($test_file);
-}
-
-sub test_file2file {
- my $test_file = shift;
-
- my $tmp_file = File::Temp->new( TMPDIR => 1 );
-
- my $source = $test_file;
- my $destination = $tmp_file->filename();
-
- note("Testing file2file: '$source' => '$destination'\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_str = slurp_raw($source);
- my $destination_str = slurp_raw($destination);
-
- my $source_hex = unpack( 'H*', $source_str );
- my $destination_hex = unpack( 'H*', $destination_str );
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
-
- ok($source_hex eq $destination_hex, 'file content compare');
-}
-
-sub test_scalar2scalar {
- my $testfile = shift;
-
- my $source = slurp_raw($testfile);
- my $destination;
-
- note("Testing scalar2scalar\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => \$source,
- destination => \$destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_hex = unpack( 'H*', $source );
- my $destination_hex = unpack( 'H*', $destination );
-
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
- ok($source_hex eq $destination_hex, 'scalar content compare');
-}
-
-sub test_scalararray2scalararray {
- my $testfile = shift;
-
- my $source = [ lines_raw($testfile) ];
- my $destination = [];
-
- note("Testing scalararray2scalararray\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_str = join( "", @$source );
- my $destination_str = join( "", @$destination );
-
- my $source_hex = unpack( 'H*', $source_str );
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
- ok($source_hex eq $destination_hex, 'scalararray content compare');
-}
-
-sub slurp_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- local $/;
- my $contents = <TMP>;
- close(TMP);
-
- return $contents;
-}
-
-sub lines_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- my @contents = <TMP>;
- close(TMP);
-
- return @contents;
-}
-
-sub hex_compare_by_lines {
- my ( $source_str, $destination_str ) = @_;
-
- my @source = split /^/m, $source_str;
- my @destination = split /^/m, $destination_str;
-
- while (@source) {
- my $ss = pop(@source);
- my $dd = pop(@destination);
- chomp $ss;
- chomp $dd;
- $ss = unpack( 'H*', $ss );
- $dd = unpack( 'H*', $dd );
- last if $ss ne $dd;
- }
- return !@source && !@destination;
-}
-
--- /dev/null
+use strict;
+use warnings;
+use utf8;
+
+use FindBin qw($Bin);
+use File::Temp qw(tempfile);
+use Test::More;
+
+BEGIN { unshift @INC, "./" }
+use Perl::Tidy;
+
+# This tests the -eos (--encode-output-strings) which was added for issue
+# git #83 to fix an issue with tidyall.
+
+# The test file is UTF-8 encoded
+
+plan( tests => 6 );
+
+test_all();
+
+sub test_all {
+ my $test_file = "$Bin/testwide-tidy.pl.src";
+ my $tidy_file = "$Bin/testwide-tidy.pl.srctdy";
+ my $tidy_str = slurp_raw($tidy_file);
+ test_file2file( $test_file, $tidy_str );
+ test_scalar2scalar( $test_file, $tidy_str );
+ test_scalararray2scalararray( $test_file, $tidy_str );
+}
+
+sub test_file2file {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $tmp_file = File::Temp->new( TMPDIR => 1 );
+
+ my $source = $test_file;
+ my $destination = $tmp_file->filename();
+
+ note("Testing file2file: '$source' => '$destination'\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_str = slurp_raw($destination);
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'file content compare');
+
+}
+
+sub test_scalar2scalar {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $source = slurp_raw($test_file);
+ my $destination;
+
+ note("Testing scalar2scalar\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos',
+ source => \$source,
+ destination => \$destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_hex = unpack( 'H*', $destination );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'scalar content compare');
+
+}
+
+sub test_scalararray2scalararray {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $source = [ lines_raw($test_file) ];
+ my $destination = [];
+
+ note("Testing scalararray2scalararray\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_str = join( '', @$destination );
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'scalararray content compare');
+}
+
+sub slurp_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ local $/;
+ my $contents = <TMP>;
+ close(TMP);
+
+ return $contents;
+}
+
+sub lines_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ my @contents = <TMP>;
+ close(TMP);
+
+ return @contents;
+}
+
+sub hex_compare_by_lines {
+ my ( $source_str, $destination_str ) = @_;
+
+ my @source = split /^/m, $source_str;
+ my @destination = split /^/m, $destination_str;
+
+ while (@source) {
+ my $ss = pop(@source);
+ my $dd = pop(@destination);
+ chomp $ss;
+ chomp $dd;
+ $ss = unpack( 'H*', $ss );
+ $dd = unpack( 'H*', $dd );
+ last if $ss ne $dd;
+ }
+ return !@source && !@destination;
+}
+++ /dev/null
-use strict;
-use warnings;
-use utf8;
-
-use FindBin qw($Bin);
-use File::Temp qw(tempfile);
-use Test::More;
-
-BEGIN { unshift @INC, "./" }
-use Perl::Tidy;
-
-# This tests the -eos (--encode-output-strings) which was added for issue
-# git #83 to fix an issue with tidyall.
-
-# The test file is UTF-8 encoded
-
-plan( tests => 6 );
-
-test_all();
-
-sub test_all {
- my $test_file = "$Bin/testwide-tidy.pl.src";
- my $tidy_file = "$Bin/testwide-tidy.pl.srctdy";
- my $tidy_str = slurp_raw($tidy_file);
- test_file2file( $test_file, $tidy_str );
- test_scalar2scalar( $test_file, $tidy_str );
- test_scalararray2scalararray( $test_file, $tidy_str );
-}
-
-sub test_file2file {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $tmp_file = File::Temp->new( TMPDIR => 1 );
-
- my $source = $test_file;
- my $destination = $tmp_file->filename();
-
- note("Testing file2file: '$source' => '$destination'\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_str = slurp_raw($destination);
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'file content compare');
-
-}
-
-sub test_scalar2scalar {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $source = slurp_raw($test_file);
- my $destination;
-
- note("Testing scalar2scalar\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => \$source,
- destination => \$destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_hex = unpack( 'H*', $destination );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'scalar content compare');
-
-}
-
-sub test_scalararray2scalararray {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $source = [ lines_raw($test_file) ];
- my $destination = [];
-
- note("Testing scalararray2scalararray\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_str = join( '', @$destination );
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'scalararray content compare');
-}
-
-sub slurp_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- local $/;
- my $contents = <TMP>;
- close(TMP);
-
- return $contents;
-}
-
-sub lines_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- my @contents = <TMP>;
- close(TMP);
-
- return @contents;
-}
-
-sub hex_compare_by_lines {
- my ( $source_str, $destination_str ) = @_;
-
- my @source = split /^/m, $source_str;
- my @destination = split /^/m, $destination_str;
-
- while (@source) {
- my $ss = pop(@source);
- my $dd = pop(@destination);
- chomp $ss;
- chomp $dd;
- $ss = unpack( 'H*', $ss );
- $dd = unpack( 'H*', $dd );
- last if $ss ne $dd;
- }
- return !@source && !@destination;
-}
projects / perltidy.git / commitdiff