view release on metacpan or  search on metacpan

script/cdif  view on Meta::CPAN

if ($app->colordump) {
    print $color_handler->colormap(
	name => '--changeme', option => '--colormap');
    exit;
}

sub color {
    $color_handler->color(@_);
}

my $prefix_re = do {
    if ($app->prefix) {
	qr/$app->{prefix_pattern}/;
    } else {
	"";
    }
};

my $DIFF;
my $OLD;
my $NEW;

if ($app->rcs) {
    my $rcsfile = shift || usage("No RCS filename\n\n");
    $DIFF = "$diff @diffopts @rcsopt $rcsfile|";
} elsif (@ARGV == 2) {
    ($OLD, $NEW) = splice(@ARGV, 0, 2);
    $DIFF = "$diff @diffopts $OLD $NEW |";
} elsif (@ARGV < 2) {
    $DIFF = shift || '-';
} else {
    usage("Arguments error.\n\n") if @ARGV;
}
warn "DIFF = \"$DIFF\"\n" if $debug{f};

my %func = do {
    my $col = $app->color ? 0 : 1;
    pairmap { $a => $b->[$col] } (
	DELETE  => [ sub { color("DELETE",  @_) }, \&bd ],
	APPEND  => [ sub { color("APPEND",  @_) }, \&bd ],
	OLD     => [ sub { color("OCHANGE", @_) }, \&ul ],
	NEW     => [ sub { color("NCHANGE", @_) }, \&ul ],
	UNKNOWN => [ sub { color("UNKNOWN", @_) }, undef ],
    );
};

my $w_pattern = do {
    if ($app->unit =~ /^char/) {
	qr/\X/s;
    } else {
	my $w = $app->unit eq 'letter' ? '' : '_';
	qr{
	    \p{Han} | \p{InHiragana}+ | \p{InKatakana}+ |
	    [$w\p{Latin}]+    |
	    [$w\p{Hang}]+     |
	    [$w\p{Cyrillic}]+ |
	    [$w\p{Arabic}]+   |
	    [$w\p{Thai}]+     |
	    \d+ |
	#   (\p{Punct})\g{-1}* |
	    [\h\r\f]*\n | \s+ | (\X)\g{-1}*
	}x;
    }
};

##
## Converter/Effector function for visible characters
##
my($converter, $effector);
use Getopt::EX::LabeledParam;
Getopt::EX::LabeledParam
    ->new(HASH => \%opt_visible)
    ->load_params (@{$app->visible});
if (my @names = grep $opt_visible{$_}, keys %opt_visible) {
    my @chars = map $visible{$_}->[0], @names;
    my %hash = map { @$_ } values %visible;
    my $re = do { local $" = ''; qr/[\Q@chars\E]/ };
    my $sub0 = sub {          s/($re)/$hash{$1}/g };
    my $sub1 = sub { $_[0] =~ s/($re)/$hash{$1}/gr };
    my $sub2 = sub {
	my $mark_re = shift;
	for (@_) {
	    $_ // next;
	    s{^$mark_re\K(?=.*$re)(.*\R?)}{
		$sub1->($1);
	    }mge;
	}
    };
    $converter = $sub2;

    if (my $color = $colormap{'VISIBLE'}) {
	my $s = ansi_code($color);
	my $e = ansi_code($color =~ s/(?=.)/~/gr); # cancel the effect
	my $symbols = join('',
			   map  { $visible{$_}->[-1] =~ s/\s+//gr }
			   @names);
	$effector = sub { s/([\Q$symbols\E]+)/${s}${1}${e}/g };
    }
}

##
## Temporary files
##
use Command::Run::Tmpfile;
my $T1 = Command::Run::Tmpfile->new;
my $T2 = Command::Run::Tmpfile->new;

##
## Total statistic info
##
my %stat;
@stat{'a', 'd', 'c', 'anl', 'dnl', 'cnl'} = (0, 0, 0, 0, 0, 0);
@stat{'anlb', 'dnlb', 'cnlb'} = (0, 0, 0);

open(DIFF, $DIFF) || die "$DIFF: $!\n";
binmode DIFF, ":encoding(utf8)";

my $stdout = IO::Divert->new;
sub sprintln { map { s/(?<=[^\n])\z/\n/r } @_ }
sub  println { print sprintln @_ }
sub print_lxl {

script/cdif  view on Meta::CPAN

	println $old if $old and $app->show_old;
	println $del if $del;
	println $new if $new and $app->show_new;
    }
    #
    # diff -c
    #
    elsif (/^\*\*\* ([\d,]+) \*\*\*\*\r?$/) {
	my $left = $1;
	print_command($_);
	my(@old, @new);
	my $oline = range($left);
	@old = read_diffc(*DIFF, $oline);
	my $new;
	if (@old and $old[0] =~ /^--- /) {
	    $new = shift @old;
	    @old = ("");
	} else {
	    $new = <DIFF>;
	}
	my $dline = map { /^-/mg } @old;
	if ($new =~ /^--- ([\d,]+) ----$/) {
	    my $right = $1;
	    my $nline = range($right);
	    if (@old == 1 and $old[0] ne "" and $oline - $dline == $nline) {
		@new = ("");
	    } else {
		@new = read_diffc(*DIFF, $nline);
	    }
	    if ($converter) {
		$converter->(qr/[\-\+\!\ ][ \t]/, @old, @new);
	    }
	    my $mark_re = qr/![ \t]/;
	    for my $i (keys @old) {
		my $cmark = "! ";
		if ($i % 2) {
		    compare(\$old[$i], \$new[$i], $mark_re) if $app->unit;
		}
		if ($app->color) {
		    $old[$i] =~ s{^([\-\!][ \t])(.*)}{
			color("OMARK", $1) . color("OTEXT", $2)
		    }mge;
		    $new[$i] =~ s{^([\+\!][ \t])(.*)}{
			color("NMARK", $1) . color("NTEXT", $2)
		    }mge;
		}
	    }
	}
	println @old if $app->show_old;
	println $new;
	println @new if $app->show_new;
    }
    #
    # diff --combined (generic)
    #
    elsif (m{^
	   (?<prefix> $prefix_re)
	   (?<command>
	     (?<mark> \@{2,} ) [ ]
	     (?<lines> (?: [-+]\d+(?:,\d+)? [ ] ){2,} )
	     \g{mark}
	     (?s:.*)
	   )
	   }x) {
	my($prefix, $command, $lines) = @+{qw(prefix command lines)};
	my $column = length $+{mark};
	my @lines = map {
	    $_ eq ' ' ? 1 : int $_
	} $lines =~ /\d+(?|,(\d+)|( ))/g;

	if (@lines != $column) {
	    print;
	    next;
	}

	my($divert, %read_opt);
	if ($prefix) {
	    $read_opt{prefix} = $prefix;
	    $divert = IO::Divert->new(FINAL => sub { s/^/$prefix/mg });
	}

	print_command($command);

	my @buf = read_unified \%read_opt, *DIFF, @lines;

	state @mark_re;
	my $mark_re = $mark_re[$column] //= do {
	    my $mark = '.' x ($column - 1);
	    qr/$mark/;
	};

	if ($converter) {
	    map { $converter->($mark_re, @$_) }
	    map { $_->lists }
	    @buf;
	}

	for my $buf (@buf) {
	    my @result = compare_unified($column, $buf, $mark_re);
	    if (@result == 3) {
		$app->show_new or splice @result, 2, 1;
		$app->show_old or splice @result, 1, 1;
	    }
	    println @result;
	}
    }
    #
    # conflict marker
    #
    elsif (/^<<<<<<<\s+(.*)/) {
      CONFLICT:
	{
	    my $c1 = $_;

	    my @old = read_until { /^=======$/ } *DIFF;
	    my $c2 = pop @old // do {
		print $c1, @old;
		last;
	    };

	    my @new = read_until { /^>>>>>>>\s+(.*)/ } *DIFF;