--- /dev/null
+# Created with: ./make_t.pl
+
+# Contents:
+#1 105484.def
+#2 align1.def
+#3 align2.def
+#4 align3.def
+#5 align4.def
+#6 align5.def
+#7 align6.def
+#8 align7.def
+#9 align8.def
+#10 align9.def
+#11 andor1.def
+#12 andor10.def
+#13 andor2.def
+#14 andor3.def
+#15 andor4.def
+#16 andor5.def
+#17 andor6.def
+#18 andor7.def
+#19 andor8.def
+#20 andor9.def
+
+# To locate test #13 you can search for its name or the string '#13'
+
+use strict;
+use Test;
+use Carp;
+use Perl::Tidy;
+my $rparams;
+my $rsources;
+my $rtests;
+
+BEGIN {
+
+ ###########################################
+ # BEGIN SECTION 1: Parameter combinations #
+ ###########################################
+ $rparams = { 'def' => "", };
+
+ ############################
+ # BEGIN SECTION 2: Sources #
+ ############################
+ $rsources = {
+
+ '105484' => <<'----------',
+switch (1) {
+ case x { 2 } else { }
+}
+----------
+
+ 'align1' => <<'----------',
+return ( $fetch_key eq $fk
+ && $store_key eq $sk
+ && $fetch_value eq $fv
+ && $store_value eq $sv
+ && $_ eq 'original' );
+----------
+
+ 'align2' => <<'----------',
+same =
+ ( ( $aP eq $bP )
+ && ( $aS eq $bS )
+ && ( $aT eq $bT )
+ && ( $a->{'title'} eq $b->{'title'} )
+ && ( $a->{'href'} eq $b->{'href'} ) );
+----------
+
+ 'align3' => <<'----------',
+# This greatly improved after dropping 'ne' and 'eq':
+if (
+ $dir eq $updir and # if we have an updir
+ @collapsed and # and something to collapse
+ length $collapsed[-1] and # and its not the rootdir
+ $collapsed[-1] ne $updir and # nor another updir
+ $collapsed[-1] ne $curdir # nor the curdir
+ ) { $bla}
+----------
+
+ 'align4' => <<'----------',
+# removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
+my $salute =
+ $name eq $EMPTY_STR ? 'Customer'
+ : $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
+ : $name =~ m/(.*), \s+ Ph[.]?D \z /xms ? "Dr $1"
+ : $name;
+----------
+
+ 'align5' => <<'----------',
+# some lists
+printline( "Broadcast", &bintodq($b), ( $b, $mask, $bcolor, 0 ) );
+printline( "HostMin", &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
+printline( "HostMax", &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
+----------
+
+ 'align6' => <<'----------',
+# align opening parens
+if ( ( index( $msg_line_lc, $nick1 ) != -1 ) ||
+ ( index( $msg_line_lc, $nick2 ) != -1 ) ||
+ ( index( $msg_line_lc, $nick3 ) != -1 ) ) {
+ do_something();
+}
+----------
+
+ 'align7' => <<'----------',
+# Alignment with two fat commas in second line
+my $ct = Courriel::Header::ContentType->new(
+ mime_type => 'multipart/alternative',
+ attributes => { boundary => unique_boundary },
+);
+----------
+
+ 'align8' => <<'----------',
+# aligning '=' and padding 'if'
+if ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value }
+elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"} = $value }
+elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"} = $value }
+----------
+
+ 'align9' => <<'----------',
+# test of aligning ||
+my $os =
+ ( $ExtUtils::MM_Unix::Is_OS2 || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Mac || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Dos || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_VMS || 0 );
+----------
+
+ 'andor1' => <<'----------',
+return 1 if $det_a < 0 and $det_b > 0 or
+ $det_a > 0 and $det_b < 0;
+----------
+
+ 'andor10' => <<'----------',
+if ( ( ($a) and ( $b == 13 ) and ( $c - 24 = 0 ) and ("test")
+ and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
+ and $test
+ ) or ( $nobody and ( $noone or $none ) )
+ )
+{ $i++; }
+----------
+
+ 'andor2' => <<'----------',
+# breaks at = or at && but not both
+my $success = ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
+----------
+
+ 'andor3' => <<'----------',
+ok( ( $obj->name() eq $obj2->name() )
+ and ( $obj->version() eq $obj2->version() )
+ and ( $obj->help() eq $obj2->help() ) );
+----------
+
+ 'andor4' => <<'----------',
+ if ( !$verbose_error && ( !$options->{'log'}
+ && ( ( $options->{'verbose'} & 8 ) || ( $options->{'verbose'} & 16 )
+ || ( $options->{'verbose'} & 32 )
+ || ( $options->{'verbose'} & 64 ) ) ) )
+----------
+
+ 'andor5' => <<'----------',
+ # two levels of && with side comments
+ if (
+ defined &syscopy
+ && \&syscopy != \©
+ && !$to_a_handle
+ && !( $from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle
+ && !( $from_a_handle && $^O eq 'mpeix' ) # and neither can MPE/iX.
+ )
+ {
+ return syscopy( $from, $to );
+ }
+----------
+
+ 'andor6' => <<'----------',
+# Example of nested ands and ors
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (
+ !null($op) and null( $op->sibling )
+ and $op->ppaddr eq "pp_null"
+ and class($op) eq "UNOP"
+ and (
+ (
+ $op->first->ppaddr =~ /^pp_(and|or)$/
+ and $op->first->first->sibling->ppaddr eq "pp_lineseq"
+ )
+ or ( $op->first->ppaddr eq "pp_lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->ppaddr eq "pp_unstack" )
+ )
+ );
+}
+----------
+
+ 'andor7' => <<'----------',
+ # original is single line:
+ $a = 1 if $l and !$r or !$l and $r;
+----------
+
+ 'andor8' => <<'----------',
+ # original is broken:
+ $a = 1
+ if $l and !$r or !$l and $r;
+----------
+
+ 'andor9' => <<'----------',
+if ( ( ( $old_new and $old_new eq 'changed' )
+ and ( $db_new and $db_new eq 'changed' )
+ and ( not defined $old_db )
+ ) or ( ( $old_new and $old_new eq 'changed' )
+ and ( $db_new and $db_new eq 'new' )
+ and ( $old_db and $old_db eq 'new' )
+ ) or ( ( $old_new and $old_new eq 'new' )
+ and ( $db_new and $db_new eq 'new' )
+ and ( not defined $old_db )
+ ) )
+{
+ return "update";
+}
+----------
+ };
+
+ ####################################
+ # BEGIN SECTION 3: Expected output #
+ ####################################
+ $rtests = {
+
+ '105484.def' => {
+ source => "105484",
+ params => "def",
+ expect => <<'#1...........',
+switch (1) {
+ case x { 2 } else { }
+}
+#1...........
+ },
+
+ 'align1.def' => {
+ source => "align1",
+ params => "def",
+ expect => <<'#2...........',
+return ( $fetch_key eq $fk
+ && $store_key eq $sk
+ && $fetch_value eq $fv
+ && $store_value eq $sv
+ && $_ eq 'original' );
+#2...........
+ },
+
+ 'align2.def' => {
+ source => "align2",
+ params => "def",
+ expect => <<'#3...........',
+same =
+ ( ( $aP eq $bP )
+ && ( $aS eq $bS )
+ && ( $aT eq $bT )
+ && ( $a->{'title'} eq $b->{'title'} )
+ && ( $a->{'href'} eq $b->{'href'} ) );
+#3...........
+ },
+
+ 'align3.def' => {
+ source => "align3",
+ params => "def",
+ expect => <<'#4...........',
+# This greatly improved after dropping 'ne' and 'eq':
+if (
+ $dir eq $updir and # if we have an updir
+ @collapsed and # and something to collapse
+ length $collapsed[-1] and # and its not the rootdir
+ $collapsed[-1] ne $updir and # nor another updir
+ $collapsed[-1] ne $curdir # nor the curdir
+ )
+{
+ $bla;
+}
+#4...........
+ },
+
+ 'align4.def' => {
+ source => "align4",
+ params => "def",
+ expect => <<'#5...........',
+# removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
+my $salute =
+ $name eq $EMPTY_STR ? 'Customer'
+ : $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
+ : $name =~ m/(.*), \s+ Ph[.]?D \z /xms ? "Dr $1"
+ : $name;
+#5...........
+ },
+
+ 'align5.def' => {
+ source => "align5",
+ params => "def",
+ expect => <<'#6...........',
+# some lists
+printline( "Broadcast", &bintodq($b), ( $b, $mask, $bcolor, 0 ) );
+printline( "HostMin", &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
+printline( "HostMax", &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
+#6...........
+ },
+
+ 'align6.def' => {
+ source => "align6",
+ params => "def",
+ expect => <<'#7...........',
+# align opening parens
+if ( ( index( $msg_line_lc, $nick1 ) != -1 )
+ || ( index( $msg_line_lc, $nick2 ) != -1 )
+ || ( index( $msg_line_lc, $nick3 ) != -1 ) )
+{
+ do_something();
+}
+#7...........
+ },
+
+ 'align7.def' => {
+ source => "align7",
+ params => "def",
+ expect => <<'#8...........',
+# Alignment with two fat commas in second line
+my $ct = Courriel::Header::ContentType->new(
+ mime_type => 'multipart/alternative',
+ attributes => { boundary => unique_boundary },
+);
+#8...........
+ },
+
+ 'align8.def' => {
+ source => "align8",
+ params => "def",
+ expect => <<'#9...........',
+# aligning '=' and padding 'if'
+if ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value }
+elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"} = $value }
+elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"} = $value }
+#9...........
+ },
+
+ 'align9.def' => {
+ source => "align9",
+ params => "def",
+ expect => <<'#10...........',
+# test of aligning ||
+my $os =
+ ( $ExtUtils::MM_Unix::Is_OS2 || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Mac || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_Dos || 0 ) +
+ ( $ExtUtils::MM_Unix::Is_VMS || 0 );
+#10...........
+ },
+
+ 'andor1.def' => {
+ source => "andor1",
+ params => "def",
+ expect => <<'#11...........',
+return 1
+ if $det_a < 0 and $det_b > 0
+ or $det_a > 0 and $det_b < 0;
+#11...........
+ },
+
+ 'andor10.def' => {
+ source => "andor10",
+ params => "def",
+ expect => <<'#12...........',
+if (
+ (
+ ($a)
+ and ( $b == 13 )
+ and ( $c - 24 = 0 )
+ and ("test")
+ and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
+ and $test
+ )
+ or ( $nobody and ( $noone or $none ) )
+ )
+{
+ $i++;
+}
+#12...........
+ },
+
+ 'andor2.def' => {
+ source => "andor2",
+ params => "def",
+ expect => <<'#13...........',
+# breaks at = or at && but not both
+my $success =
+ ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
+#13...........
+ },
+
+ 'andor3.def' => {
+ source => "andor3",
+ params => "def",
+ expect => <<'#14...........',
+ok( ( $obj->name() eq $obj2->name() )
+ and ( $obj->version() eq $obj2->version() )
+ and ( $obj->help() eq $obj2->help() ) );
+#14...........
+ },
+
+ 'andor4.def' => {
+ source => "andor4",
+ params => "def",
+ expect => <<'#15...........',
+ if (
+ !$verbose_error
+ && (
+ !$options->{'log'}
+ && ( ( $options->{'verbose'} & 8 )
+ || ( $options->{'verbose'} & 16 )
+ || ( $options->{'verbose'} & 32 )
+ || ( $options->{'verbose'} & 64 ) )
+ )
+ )
+#15...........
+ },
+
+ 'andor5.def' => {
+ source => "andor5",
+ params => "def",
+ expect => <<'#16...........',
+ # two levels of && with side comments
+ if (
+ defined &syscopy
+ && \&syscopy != \©
+ && !$to_a_handle
+ && !( $from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle
+ && !( $from_a_handle && $^O eq 'mpeix' ) # and neither can MPE/iX.
+ )
+ {
+ return syscopy( $from, $to );
+ }
+#16...........
+ },
+
+ 'andor6.def' => {
+ source => "andor6",
+ params => "def",
+ expect => <<'#17...........',
+# Example of nested ands and ors
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (
+ !null($op) and null( $op->sibling )
+ and $op->ppaddr eq "pp_null"
+ and class($op) eq "UNOP"
+ and (
+ (
+ $op->first->ppaddr =~ /^pp_(and|or)$/
+ and $op->first->first->sibling->ppaddr eq "pp_lineseq"
+ )
+ or ( $op->first->ppaddr eq "pp_lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->ppaddr eq "pp_unstack" )
+ )
+ );
+}
+#17...........
+ },
+
+ 'andor7.def' => {
+ source => "andor7",
+ params => "def",
+ expect => <<'#18...........',
+ # original is single line:
+ $a = 1 if $l and !$r or !$l and $r;
+#18...........
+ },
+
+ 'andor8.def' => {
+ source => "andor8",
+ params => "def",
+ expect => <<'#19...........',
+ # original is broken:
+ $a = 1
+ if $l and !$r
+ or !$l and $r;
+#19...........
+ },
+
+ 'andor9.def' => {
+ source => "andor9",
+ params => "def",
+ expect => <<'#20...........',
+if (
+ (
+ ( $old_new and $old_new eq 'changed' )
+ and ( $db_new and $db_new eq 'changed' )
+ and ( not defined $old_db )
+ )
+ or ( ( $old_new and $old_new eq 'changed' )
+ and ( $db_new and $db_new eq 'new' )
+ and ( $old_db and $old_db eq 'new' ) )
+ or ( ( $old_new and $old_new eq 'new' )
+ and ( $db_new and $db_new eq 'new' )
+ and ( not defined $old_db ) )
+ )
+{
+ return "update";
+}
+#20...........
+ },
+ };
+
+ my $ntests = 0 + keys %{$rtests};
+ plan tests => $ntests;
+}
+
+###############
+# EXECUTE TESTS
+###############
+
+foreach my $key ( sort keys %{$rtests} ) {
+ my $output;
+ my $sname = $rtests->{$key}->{source};
+ my $expect = $rtests->{$key}->{expect};
+ my $pname = $rtests->{$key}->{params};
+ my $source = $rsources->{$sname};
+ my $params = defined($pname) ? $rparams->{$pname} : "";
+ my $stderr_string;
+ my $errorfile_string;
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$params,
+ argv => '', # for safety; hide any ARGV from perltidy
+ stderr => \$stderr_string,
+ errorfile => \$errorfile_string, # not used when -se flag is set
+ );
+ if ( $err || $stderr_string || $errorfile_string ) {
+ if ($err) {
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$err );
+ }
+ if ($stderr_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<STDERR>>\n$stderr_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$stderr_string );
+ }
+ if ($errorfile_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<.ERR file>>\n$errorfile_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$errorfile_string );
+ }
+ }
+ else {
+ ok( $output, $expect );
+ }
+}
projects / perltidy.git / blobdiff