view release on metacpan or  search on metacpan

lib/App/ccdiff.pm  view on Meta::CPAN

    chr_new	=> "\x{25b2}",
    chr_old	=> "\x{25bc}",
    ellipsis	=> 0,
    emacs	=> 0,
    header	=> 1,	# A color name is allowed
    heuristics	=> 0,
    index	=> 0,
    iwbzusepp	=> 0,
    new_label	=> undef,
    old_label	=> undef,
    markers	=> 0,
    new		=> "green",
    old		=> "red",
    reverse	=> 0,
    swap	=> 0,
    threshold	=> 2,
    utf8	=> 0,
    verbose	=> "cyan",
    );
read_rc ();

my $opt_a = $rc{ascii};
my $opt_b;
my $opt_B;
#y $opt_c;
my $opt_E;
my $opt_h = $rc{heuristics};
my $opt_H = $rc{header};
my $opt_i;
my $opt_I = $rc{index};
my $opt_m = $rc{markers};
my $opt_r = $rc{reverse};
my $opt_s = $rc{swap};
my $opt_t = $rc{threshold};
my $opt_e = $rc{ellipsis};
my $opt_u = $rc{unified};
my $opt_U = $rc{utf8};
my $opt_v = 0;
my $opt_w;
my $opt_Z;
my $emacs     = $rc{emacs};
my $old_color = $rc{old};
my $new_color = $rc{new};
my $rev_color = $rc{bg};
my $cli_color = $ENV{CLICOLOR};	# https://bixense.com/clicolors/
my $no_colors = $ENV{NO_COLOR}; # https://no-color.org
my $old_label = $rc{old_label};
my $new_label = $rc{new_label};
my $list_colors;
my $diff_class;

if ($no_colors) {
    $ENV{CLICOLOR_FORCE}	and $no_colors = 0;
    }
elsif (defined $cli_color) {
    # true $cli_color is the default for ccdiff
    !$cli_color || !-t		and $no_colors = 1;
    }

unless (caller) {
    $ENV{CCDIFF_OPTIONS} and unshift @ARGV, split m/\s+/ => $ENV{CCDIFF_OPTIONS};
    GetOptions (
	"help|?"	=> sub { usage (0); },
	"V|version"	=> sub { say "$CMD [$VERSION]"; exit 0; },
	  "man"		=> sub { pod_nroff (); },
	  "info"	=> sub { pod_text  (); },

	"U|utf-8!"		=> \$opt_U,
	  "dc|diff-class=s"	=> \$diff_class,
	  "pp!"			=> sub { $diff_class = "PP" },

    #   "c|context:3"		=> \$opt_c,	# implement context-diff?
	"u|unified:3"		=> \$opt_u,
	"I|idx|index:-1"	=> \$opt_I,
	"t|threshold=i"		=> \$opt_t,
	"H|header!"		=> \$opt_H,
	  "HC|header-color=s"	=> \$opt_H,
	"h|heuristics=i"	=> \$opt_h,
	"e|ellipsis=i"		=> \$opt_e,
	  "emacs!"		=> \$emacs,

	"a|ascii"		=> sub { $opt_a ^= 1 },
	"m|markers"		=> sub { $opt_m ^= 1 },
	"r|reverse|invert"	=> sub { $opt_r ^= 1 },
	"s|swap!"		=> sub { $opt_s ^= 1 },

	"i|ignore-case!"			=> \$opt_i,
	"w|ignore-all-space!"			=> \$opt_w,
	"b|ignore-ws|ignore-space-change!"	=> \$opt_b,
	"Z|ignore-trailing-space!"		=> \$opt_Z,
	"E|ignore-tab-expansion!"		=> \$opt_E, # NYI
	"B|ignore-blank-lines!"			=> \$opt_B, # Partly implemented

	  "old-label|label-old=s"		=> \$old_label,
	  "new-label|label-new=s"		=> \$new_label,

	"p|pink!"		=> sub { $old_color = "magenta" },
	  "old=s"		=> \$old_color,
	  "new=s"		=> \$new_color,
	  "bg=s"		=> \$rev_color,
	  "no-colors"		=> \$no_colors,
	  "list-colors!"	=> \$list_colors,
	  "settings|defaults"	=> sub {
		binmode STDOUT, ":encoding(utf-8)";
		printf "%-10s : %s\n", $_, $rc{$_} // "<undef>" for sort keys %rc;
		exit 0;
		},

	"v|verbose:1"	=> \$opt_v,
	) or usage (1);
    }

$opt_w      and $opt_b = $opt_Z = $opt_E = $opt_B = 1;
$opt_h >= 1 and $opt_h /= 100;

sub pod_text {
    require Pod::Text::Color;
    my $m = $no_colors ? "Pod::Text" : "Pod::Text::Color";
    my $p = $m->new ();
    open my $fh, ">", \my $out;
    $p->parse_from_file ($0, $fh);
    close $fh;
    print $out;
    exit 0;
    } # pod_text

sub pod_nroff {
    first { -x "$_/nroff" } grep { -d } split m/:+/ => $ENV{PATH} or pod_text ();

    require Pod::Man;
    my $p = Pod::Man->new ();
    open my $fh, "|-", "nroff", "-man";
    $p->parse_from_file ($0, $fh);
    close $fh;
    exit 0;
    } # pod_nroff

# Color initialization
for ($old_color, $new_color, $rev_color) {
    s/^(.*)[ _]bold$/bold $1/i;
    s/^bold_/bold /i;
    }
my %clr = map { $_ => color (s{^(.*)[ _]bold$}{bold $1}ir =~
                             s{^bold[ _]}{bold }ir) }
	  map {( $_, "on_$_", "bold $_" )}
    qw( red green blue black white cyan magenta yellow );
$clr{$_} //= color ($_) for tac_colors ();
$no_colors and $clr{$_} = "" for keys %clr;
$clr{none} = $clr{on_none} = "";

my ($reset,   $bg_new,  $bg_old,
    $chr_cml, $chr_cmr, $chr_ctx, $chr_eli, $chr_eql, $chr_lft,
    $chr_new, $chr_old, $chr_rgt,
    $clr_dbg, $clr_grn, $clr_new, $clr_old, $clr_red, $clr_rev,
    $cmp_sub) = (RESET);

if ($list_colors) {
    my @clr = map { sprintf "%s%-18s%s", $clr{$_}, $_, $reset } sort keys %clr;
    while (@clr) {
	say join "  " => map { $_ // "" } splice @clr, 0, 4;
	}
    exit;
    }

sub set_options {
    for ([ \$old_color, $rc{old} ], [ \$new_color, $rc{new} ], [ \$rev_color, $rc{bg} ]) {
	my ($c, $def) = @$_;
	$$c && exists $clr{$$c} and next;
	warn "color ", $$c // "(undefined)", " is unknown, using $def instead\n";
	$$c = $def;
	}
    $clr_red = $clr{$old_color};
    $clr_grn = $clr{$new_color};
    $clr_rev = $clr{$rev_color};
    $clr_dbg = $opt_r && exists $clr{"on_$rc{verbose}"} ? $clr{"on_$rc{verbose}"} : $clr{$rc{verbose}};
    $reset   = $no_colors ? "" : RESET;

    $bg_old = $clr{$rc{bg_old} || ($opt_r ? "on_$old_color" =~ s/bold //ir :
					       "on_$rev_color" =~ s/bold //ir)};
    $bg_new = $clr{$rc{bg_new} || ($opt_r ? "on_$new_color" =~ s/bold //ir :
					       "on_$rev_color" =~ s/bold //ir)};
    $clr_old = $opt_r ? $clr_rev . $bg_old : $clr_red . $bg_old;
    $clr_new = $opt_r ? $clr_rev . $bg_new : $clr_grn . $bg_new;
    $opt_s and ($clr_new, $clr_old) = ($clr_old, $clr_new);
    # Indicators
    if ($opt_a) {
	@rc{qw( chr_old chr_new chr_cml chr_cmr chr_eli chr_eli_v )} = qw( ^ ^ > < - <> );
	}

lib/App/ccdiff.pm  view on Meta::CPAN

	    $o eq "ascii"			and $opt_a = $v;
	    $o eq "bg"				and $rev_color = $v;
#	    $o eq "context"			and $opt_c = $v;
	    $o eq "ellipsis"			and $opt_e = $v;
	    $o eq "emacs"			and $emacs = $v;
	    $o eq "header"			and $opt_H = $v;
	    $o eq "heuristics"			and $opt_h = $v;
	    $o eq "ignore-all-space"		and $opt_w = $v;
	    $o eq "ignore-blank-lines"		and $opt_B = $v;
	    $o eq "ignore-case"			and $opt_i = $v;
	    $o eq "ignore-space-change"		and $opt_b = $v;
	    $o eq "ignore-tab-expansion"	and $opt_E = $v;
	    $o eq "ignore-trailing-space"	and $opt_Z = $v;
	    $o eq "index"			and $opt_I = $v;
	    $o eq "list-colors"			and $list_colors = $v;
	    $o eq "markers"			and $opt_m = $v;
	    $o eq "new"				and $new_color = $v;
	    $o eq "old"				and $old_color = $v;
	    $o eq "new-label"			and $new_label = $v;
	    $o eq "old-label"			and $old_label = $v;
	    $o eq "reverse"			and $opt_r = $v;
	    $o eq "swap"			and $opt_s = $v;
	    $o eq "threshold"			and $opt_t = $v;
	    $o eq "unified"			and $opt_u = $v;
	    $o eq "unified"			and $opt_u = $v;
	    $o eq "utf-8"			and $opt_U = $v;
	    $o eq "verbose"			and $opt_v = $v;

	    if ($o eq "out") {
		open   $fh, ">", $v or die "Cannot select out: $!\n";
		select $fh;
		}
	    }
	}

    set_options ();
    $emacs and @_ == 0 && -f $f1 && -f "$f1~" and ($f1, $f2) = ("$f1~", $f1);

    $f1 eq "-" && $f2 eq "-" and usage (1);

        binmode STDERR, ":encoding(utf-8)";

    if ($opt_U) {
	binmode STDIN,  ":encoding(utf-8)";
	binmode STDOUT, ":encoding(utf-8)";
	}

    my @d1 = ref $f1 eq "ARRAY" ? @$f1 : $f1 eq "-" ? <STDIN> : do {
	open my $fh, "<", $f1 or die "$f1: $!\n";
	$opt_U and binmode $fh, ":encoding(utf-8)";
	<$fh>;
	};
    my @d2 = ref $f2 eq "ARRAY" ? @$f2 : $f2 eq "-" ? <STDIN> : do {
	open my $fh, "<", $f2 or die "$f2: $!\n";
	$opt_U and binmode $fh, ":encoding(utf-8)";
	<$fh>;
	};
    if ($opt_H) {
	my $hc = "";
	if ($opt_H =~ m/^\w\w+/) {
	    my ($hfg, $hbg) = split m/_?(?=on_)/ => lc $opt_H =~ s/\s+/_/gr;
	    $hfg && defined $clr{$hfg} and $hc .= $clr{$hfg};
	    $hbg && defined $clr{$hbg} and $hc .= $clr{$hbg};
	    }
	my $nl = max length $f1, length $f2, 7;
	my $sl = $hc ? ($ENV{COLUMNS} || 80) - 4 - $nl : 1;
	my $hi = -1;
	my @hi = ($old_label, $new_label);
	my @h  = map { $hi++; -f $_
	    ? { tag   => "",
		name  => $_,
		stamp => scalar localtime ((stat $_)[9]),
		}
	    : { tag   => "",
		name  => $hi[$hi] // "*STDIN",
		stamp => scalar localtime,
		}
	    } $f1, $f2;
	if (defined $opt_u) {
	    ($h[0]{tag}, $h[1]{tag}) = ("---", "+++");
	    $sl -= 2;
	    printf "%s%s %-*s %-*s%s\n", $hc, $_->{tag},
		$nl, $_->{name}, $sl, $_->{stamp}, $clr{reset} for @h;
	    }
	#elsif ($opt_c) { # diff -c also provides (ugly) headers, but opt_c is NYI
	#   }
	else {
	    ($h[0]{tag}, $h[1]{tag}) = ("<", ">");
	    printf "%s%s %-*s %-*s%s\n", $hc, $_->{tag},
		$nl, $_->{name}, $sl, $_->{stamp}, $clr{reset} for @h;
	    }
	}

    my $diff = $diff_class->new (\@d1, \@d2, $cmp_sub);
    $diff->Base (1);

    my ($N, $idx, @s) = (0, 0);
    while ($diff->Next) {
	$N++;
	if ($diff->Same) {
	    if (defined $opt_u) {
		@s = $diff->Items (1);
		$N > 1 and print "$chr_ctx$_" for grep { defined } @s[0..($opt_u - 1)];
		unshift @s, undef while @s < $opt_u;
		}
	    next;
	    }
	my $sep = "";
	my @d  = map {[ $diff->Items ($_) ]} 1, 2;
	my @do = @{$d[0]};
	my @dn = @{$d[1]};

	if ($opt_B and "@do" !~ m/\S/ && "@dn" !~ m/\S/) {
	    # Modify @s for -u?
	    next;
	    }
	if ($opt_I) {
	    $idx++;
	    $opt_I > 0 && $idx != $opt_I and next;
	    printf "%s[%03d]%s ", ${clr_dbg}, $idx, $reset;
	    }

	if (!@dn) {
	    printf "%d,%dd%d\n", $diff->Get (qw( Min1 Max1 Max2 ));
	    $_ = $clr_old . (s/$/$reset/r) for @do;
	    }
	elsif (!@do) {
	    printf "%da%d,%d\n", $diff->Get (qw( Max1 Min2 Max2 ));
	    $_ = $clr_new . (s/$/$reset/r) for @dn;
	    }
	else {
	    $sep = "---\n" unless defined $opt_u;
	    printf "%d,%dc%d,%d\n", $diff->Get (qw( Min1 Max1 Min2 Max2 ));
	    if ($opt_t > 0 and abs (@do - @dn) > $opt_t) {
		$_ = $clr_old . (s/$/$reset/r) for @do;
		$_ = $clr_new . (s/$/$reset/r) for @dn;
		}
	    else {
		my @D = subdiff (@d, my $heu = {});
		if ($opt_h and $heu->{pct} > $opt_h) {
		    $_ = $clr_old . (s/$/$reset/r) for @do;
		    $_ = $clr_new . (s/$/$reset/r) for @dn;
		    }
		else {
		    @do = @{$D[0]};
		    @dn = @{$D[1]};
		    }
		}
	    }
	if ($opt_u and @s) {
	    print "$chr_ctx$_" for grep { defined } map { $s[$#s - $opt_u + $_] } 1..$opt_u;
	    }
	print "$chr_lft$_" for @do;
	print $sep;
	print "$chr_rgt$_" for @dn;
	}

    if ($fh) {
	select STDOUT;
	close $fh;
	}
    } # ccdiff

sub subdiff {
    my ($old, $new, $heu) = @_;
    my $d = $diff_class->new (map { [ map { split m// } @$_ ] } $old, $new);
    my ($d1, $d2, $x1, $x2, @h1, @h2) = ("", "", "", "");
    my ($cml, $cmr) = $opt_v < 2 ? ("", "") : ($chr_cml, $chr_cmr);
    my ($cmd, $cma) = ($chr_old, $chr_new);
    @{$heu}{qw( old new same )} = (1, 1, 1); # prevent div/0
    while ($d->Next) {
	my @c  = map {[ $d->Items ($_) ]} 1, 2;
	my @co = @{$c[0]};
	my @cn = @{$c[1]};
	if ($d->Same) {
	    $heu->{same} += scalar @co;
	    my $e = $chr_eli;
	    my $c = join "" => @co;
	    if ($opt_e) {
		my $join = "";
		foreach my $sc (split m/\n/ => $c) {
		    $_ .= $join for $d1, $d2, $x1, $x2;
		    $join = "\n";
		    my $l  = length $sc;      # The length of this "same" chunck
		    my $le = $l - 2 * $opt_e; # The length of the text replaces with ellipsis
		    my $ee = $opt_v <= 1 ? $e : $e =~ s/^.\K(?=.$)/$le/r;
		    if ($le > length $ee) {
			my $lsc = substr $sc, 0,           $opt_e;
			$d1 .= $lsc;
			$d2 .= $lsc;
			$lsc =~ s/\S/$chr_eql/g;
			$x1 .= $lsc;
			$x2 .= $lsc;
			my $rsc = substr $sc, $l - $opt_e, $opt_e;
			$d1 .= $clr_dbg . $ee . $reset . $rsc;
			$d2 .= $clr_dbg . $ee . $reset . $rsc;
			$rsc =~ s/\S/$chr_eql/g;
			$x1 .= $chr_eql x length ($ee) . $rsc;
			$x2 .= $chr_eql x length ($ee) . $rsc;
			next;
			}
		    else {
			$d1 .= $sc;
			$d2 .= $sc;
			$sc =~ s/\S/$chr_eql/g;
			$x1 .= $sc;
			$x2 .= $sc;
			}
		    }
		next;
		}
	    $d1 .= $c;
	    $d2 .= $c;
	    $c =~ s/\S/$chr_eql/g;
	    $x1 .= $c;
	    $x2 .= $c;
	    next;
	    }
	if (@co) {
	    $heu->{old} += scalar @co;
	    $d1 .= $cml.$clr_old;
	    $d1 .= s/\n/$reset\n$clr_old/gr for @co;
	    $d1 .= $reset.$cmr;
	    $x1 .= $_ for map { s/[^\t\r\n]/$cmd/gr } @co;
	    $opt_v and push @h1, map { $opt_U ? charnames::viacode (ord) : unpack "H*"; } @co;
	    }
	if (@cn) {
	    $heu->{new} += scalar @cn;
	    $d2 .= $cml.$clr_new;
	    $d2 .= s/\n/$reset\n$clr_new/gr for @cn;
	    $d2 .= $reset.$cmr;
	    $x2 .= $_ for map { s/[^\t\r\n]/$cma/gr } @cn;
	    $opt_v and push @h2, map { $opt_U ? charnames::viacode (ord) : unpack "H*"; } @cn;
	    }
	}
    $heu->{pct} = ($heu->{old} + $heu->{new}) / (2 * $heu->{same});
    my @d = map { [ split m/(?<=\n)/ => s/\n*\z/\n/r ] } $d1, $d2;
    if ($opt_m) {
	$opt_v > 1 and s/(\S+)/ $1 /g for $x1, $x2;
	s/[ \t]*\n*\z/\n/ for $x1, $x2;
	my @x = map { /\S/ ? [ split m/(?<=\n)/ ] : [] } $x1, $x2;
	foreach my $n (0, 1) {
	    @{$x[$n]} and $d[$n] = [ map {( $d[$n][$_], $x[$n][$_] // "" )} 0 .. (scalar @{$d[$n]} - 1) ];
	    }
	}
    if ($opt_v) {
	$opt_U && $opt_v > 2 and $_ .= sprintf " (U+%06X)", charnames::vianame ($_) for @h1, @h2;
	@h1 and push @{$d[0]}, sprintf " -- ${clr_dbg}verbose$reset : %s\n", join ", " => map { $clr_old.$_.$reset } @h1;
	@h2 and push @{$d[1]}, sprintf " -- ${clr_dbg}verbose$reset : %s\n", join ", " => map { $clr_new.$_.$reset } @h2;
	}
    @d;
    } # subdiff

sub read_rc {
    my $home = $ENV{HOME} || $ENV{USERPROFILE} || $ENV{HOMEPATH};
    foreach my $rcf (
	    "$home/ccdiff.rc",
	    "$home/.ccdiffrc",
	    "$home/.config/ccdiff",
	    ) {
	-s $rcf or next;
	(stat $rcf)[2] & 022 and next;
	open my $fh, "<", $rcf or next;
	while (<$fh>) {
	    my ($k, $v) = (m/^\s*([-\w]+)\s*[:=]\s*(.*\S)/) or next;
	    $rc{ lc $k
	        =~ s{[-_]colou?r$}{}ir
	        =~ s{background}{bg}ir
	        =~ s{^(?:unicode|utf-?8?)$}{utf8}ir
	      } = $v
		=~ s{U\+?([0-9A-Fa-f]{2,7})}{chr hex $1}ger
		=~ s{^(?:no|false)$}{0}ir
		=~ s{^(?:yes|true)$}{-1}ir; # -1 is still true
	    }
	}
    } # read_rc

# Return the known colors from Term::ANSIColor
# Stolen straight from the pm
sub tac_colors {
    my %c256;
    foreach my $r (0 .. 5) {
        foreach my $g (0 .. 5) {
            $c256{lc $_}++ for map {("RGB$r$g$_", "ON_RGB$r$g$_")} 0 .. 5;
	    }
	}
    $c256{lc $_}++ for
      # Basic colors
      qw(
	CLEAR           RESET             BOLD            DARK
	FAINT           ITALIC            UNDERLINE       UNDERSCORE
	BLINK           REVERSE           CONCEALED

	BLACK           RED               GREEN           YELLOW
	BLUE            MAGENTA           CYAN            WHITE
	ON_BLACK        ON_RED            ON_GREEN        ON_YELLOW
	ON_BLUE         ON_MAGENTA        ON_CYAN         ON_WHITE

	BRIGHT_BLACK    BRIGHT_RED        BRIGHT_GREEN    BRIGHT_YELLOW
	BRIGHT_BLUE     BRIGHT_MAGENTA    BRIGHT_CYAN     BRIGHT_WHITE
	ON_BRIGHT_BLACK ON_BRIGHT_RED     ON_BRIGHT_GREEN ON_BRIGHT_YELLOW