From: Steve Hancock Date: Thu, 27 Jan 2022 03:23:55 +0000 (-0800) Subject: added t/.gitattributes; trying to prevent auto cr/lf conversion X-Git-Tag: 20211029.06~11 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=9d3347aabaf2c71dd43540ad6a7543df802fa684;p=perltidy.git added t/.gitattributes; trying to prevent auto cr/lf conversion --- diff --git a/.github/workflows/perltest.yml b/.github/workflows/perltest.yml index 2c67a88a..83bebeb1 100644 --- a/.github/workflows/perltest.yml +++ b/.github/workflows/perltest.yml @@ -50,11 +50,6 @@ jobs: # 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 . diff --git a/bin/perltidy b/bin/perltidy index 6781835d..218e309e 100755 --- a/bin/perltidy +++ b/bin/perltidy @@ -3446,9 +3446,9 @@ To prevent this, and thereby always form longer lines, use B<-nboa>. =item B -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 @@ -3486,6 +3486,36 @@ For example, given the script: ...; }; +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: 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 diff --git a/lib/Perl/Tidy/Formatter.pm b/lib/Perl/Tidy/Formatter.pm index 19392a31..f3a65c9f 100644 --- a/lib/Perl/Tidy/Formatter.pm +++ b/lib/Perl/Tidy/Formatter.pm @@ -1667,44 +1667,36 @@ EOM '?' => ':', ); - # 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. @@ -1716,6 +1708,14 @@ EOM $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 #------------------------------------------------------------ @@ -2246,6 +2246,96 @@ EOM 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(<{$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(<{'}'} + && $rkeep_break_hash->{'}'} eq '1' + && !$rkeep_break_hash->{')'} + && !$rkeep_break_hash->{']'} ) + { + $rkeep_break_hash->{'('} = 1; + $rkeep_break_hash->{'['} = 1; + Warn(<[$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; } @@ -8204,15 +8332,24 @@ sub match_paren_flag { 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? diff --git a/t/.gitattributes b/t/.gitattributes new file mode 100644 index 00000000..fa1385d9 --- /dev/null +++ b/t/.gitattributes @@ -0,0 +1 @@ +* -text diff --git a/t/testwide-passthrough.t b/t/testwide-passthrough.t new file mode 100644 index 00000000..71a8a292 --- /dev/null +++ b/t/testwide-passthrough.t @@ -0,0 +1,151 @@ +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 = ; + close(TMP); + + return $contents; +} + +sub lines_raw { + my $filename = shift; + + open( TMP, '<', $filename ); + binmode( TMP, ':raw' ); + my @contents = ; + 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; +} + diff --git a/t/testwide-passthrough.t.skip b/t/testwide-passthrough.t.skip deleted file mode 100644 index 71a8a292..00000000 --- a/t/testwide-passthrough.t.skip +++ /dev/null @@ -1,151 +0,0 @@ -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 = ; - close(TMP); - - return $contents; -} - -sub lines_raw { - my $filename = shift; - - open( TMP, '<', $filename ); - binmode( TMP, ':raw' ); - my @contents = ; - 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; -} - diff --git a/t/testwide-tidy.t b/t/testwide-tidy.t new file mode 100644 index 00000000..7bff3f91 --- /dev/null +++ b/t/testwide-tidy.t @@ -0,0 +1,144 @@ +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 = ; + close(TMP); + + return $contents; +} + +sub lines_raw { + my $filename = shift; + + open( TMP, '<', $filename ); + binmode( TMP, ':raw' ); + my @contents = ; + 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; +} diff --git a/t/testwide-tidy.t.skip b/t/testwide-tidy.t.skip deleted file mode 100644 index 7bff3f91..00000000 --- a/t/testwide-tidy.t.skip +++ /dev/null @@ -1,144 +0,0 @@ -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 = ; - close(TMP); - - return $contents; -} - -sub lines_raw { - my $filename = shift; - - open( TMP, '<', $filename ); - binmode( TMP, ':raw' ); - my @contents = ; - 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; -}