#!/usr/bin/perl

# Created on: 2009-08-07 18:33:36
# Create by:  Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use strict;
use warnings;
use version;
use Carp qw/carp croak confess cluck/;
use Getopt::Long;
use Pod::Usage;
use List::Util qw/sum/;
use List::MoreUtils qw/uniq/;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use FindBin qw/$Bin/;
use Term::ANSIColor qw/:constants/;
use Path::Tiny;
use File::Copy;
use File::CodeSearch;
use File::CodeSearch::Replacer;
use File::TypeCategories;
use IO::Prompt qw/prompt/;

our $VERSION = version->new('0.7.5');
my ($name)   = $PROGRAM_NAME =~ m{^.*/(.*?)$}mxs;
my $REVERSE  = REVERSE;
my $RESET    = RESET;
my $BLUE     = BLUE;
my $BOLD     = BOLD;
my $ON_RED   = ON_RED;
my $ON_GREEN = ON_GREEN;

my %option = (
    verbose => 0,
    man     => 0,
    help    => 0,
    VERSION => 0,
);

if ( !@ARGV ) {
    pod2usage( -verbose => 1 );
}

main();
exit 0;

sub main {

    Getopt::Long::Configure('bundling');
    GetOptions(
        \%option,
        'sre_all|all|a',
        'sre_words|words|W',
        'sre_ignore_case|ignore|i',
        'sre_whole|whole|w',
        'sre_sub_matches|contains|c=s@',
        'sre_sub_not_matches|not-contains|notcontains|S=s@',
        'sre_last|last|L=s@',
        'sre_smart|smart|m',
        'replace|r=s',
        'path|p=s@',
        'file_symlinks|links|l',
        'file_recurse|R!',
        'file_contains=s',
        'file_not_contains=s',
        'file_include|include|n=s@',
        'file_include_type|include_type|int|N=s@',
        'file_exclude|exclude|x=s@',
        'file_exclude_type|exclude_type|ext|X=s@',
        'file_ignore=s',
        'file_ignore_add|d=s',
        'file_ignore_remove|I=s',
        'out_suround|suround|context|C=n',
        'out_suround_before|before|B=n',
        'out_suround_after|after|A=n',
        'out_totals|totals|t',
        'out_files_only|files-only|f',
        'out_quiet|quiet|q!',
        'out_unique|unique|u!',
        'out_limit|limit=i',
        'project|P=s',
        'yes|y',
        'no',
        'execute|execute-files|E=s',
        'config|c=s',
        'bw|g',
        'verbose|v+',
        'man',
        'help',
        'VERSION!',
    ) or pod2usage(2);

    if ( $option{'VERSION'} ) {
        print "$name Version = $VERSION\n";
        exit 1;
    }
    elsif ( $option{'man'} ) {
        pod2usage( -verbose => 2 );
    }
    elsif ( $option{'help'} ) {
        pod2usage( -verbose => 1 );
    }
    elsif ( !@ARGV ) {
        warn "No search term specified\n";
        pod2usage( -verbose => 1 );
    }

    # do stuff here

    $option{path} = [ map {glob $_} map {split /:/, $_} $option{path} ? @{$option{path}} : ('.') ];

    if ($option{out_suround}) {
        $option{out_suround_before} ||= $option{out_suround};
        $option{out_suround_after}  ||= $option{out_suround};
        delete $option{out_suround};
    }

    parse_config(\%option);

    my $lines = 80;
    if ($option{sre_smart}) {
        ($lines) = split /\s+/, `stty size` || 40;
        if (( !$option{file_include_type} || !@{ $option{file_include_type} }) && grep {$_ eq $ARGV[0]} qw/n b ss/) {
            $option{file_include_type}[0] = 'programing';
        }
        if ( !exists $option{ignore} ) {
            my $re = join ' ', @ARGV;
            if ( $re =~ /[A-Z]/ && $re =~ /[a-z]/ ) {
                $option{ignore} = 0;
            }
            else {
                $option{ignore} = 1;
            }
        }
    }

    warn Dumper { params('file', %option) } if $option{verbose};
    my $files = File::TypeCategories->new(params('file', %option));

    warn Dumper { params('sre', %option), re => \@ARGV } if $option{verbose};
    my $hl =
        $option{replace} ? File::CodeSearch::Replacer->new( params('sre', %option), re => \@ARGV, replace => $option{replace} )
        :                  File::CodeSearch::Highlighter->new( params('sre', %option), re => \@ARGV );

    if ($option{bw}) {
        $REVERSE = '';
        $RESET   = '';
        $BLUE    = '';
        $BOLD    = '';
        $ON_RED  = '';
        $hl->before_match('');
        $hl->after_match('');
        $hl->before_nomatch('');
        $hl->after_nomatch('');
    }
    warn Dumper {params('out',%option)}, \%option if $option{verbose};
    my $cs = File::CodeSearch->new( regex => $hl, files => $files, params('out',%option) );

    my $fh = \*STDOUT;
    my %match;
    my %found;
    my $out = '';
    if ( !$option{sre_smart} || $option{replace} ) {
        $option{bw} = 1;
    }
    $cs->search(
        searcher(\%found, \$out, \%match, $hl, $lines, $fh),
        @{ $option{path} }
    );
    if ($out) {
        if ($option{sre_smart}) {
            print $out;
        }
        else {
            print {$fh} $out;
        }
    }

    if ($option{out_unique}) {
        print join "\n", sort keys %match;
        print "\n";
    }
    if ($option{execute}) {
        system $option{execute} . ' ' . join ' ', sort keys %found;
    }
    if ($option{out_totals}) {
        print "\nTotal matches " . (sum values %found) . "\n";
    }

    return;
}

sub searcher {
    my ($found, $out, $match, $hl, $lines, $fh) = @_;
    my $last_file = undef;
    my $answer = { all => $option{yes}, save_all => $option{yes} };
    my $content = '';

    return sub {
        my ($line, $file, $line_no, %stuff ) = @_;
        confess "No line number provided!\n" if !defined $line_no;
        my $saved = 0;
        my $post  = 0;

        if ( !$found->{$file} && !$option{out_unique} && !($option{out_files_only} && $option{out_totals}) ) {
            $$out .= "${file}\n";
        }
        $found->{$file}++;
        if (!defined $last_file || $file ne $last_file) {
            if ( defined $last_file ) {
                if ( $option{out_files_only} && $option{out_totals} ) {
                    $$out .= "$last_file ($found->{$last_file})\n";
                }
            }
            $last_file = $file;
        }
        return if $option{out_files_only};

        # check if there were lines after the last match and display them
        if ( $stuff{after} && @{ $stuff{after} } ) {
            my @after = @{ $stuff{after} };
            my $count = $stuff{last_line_no} + 1;
            for my $after_line ( @after ) {
                last if $line && $line eq $after_line;
                $$out .= sprintf $REVERSE . '%4i: ' . $RESET . '%s', $count++, $after_line;
            }
        }
        # check if there were lines before this match and display them
        if ( $stuff{before} && @{ $stuff{before} } ) {
            my @before = @{ $stuff{before} };
            my $count = @before;
            for my $before_line ( @before ) {
                confess Dumper(\%stuff) . "Bad line" if !defined $before_line || !defined $count;
                $$out .= sprintf $REVERSE . '%4i: ' . $RESET . $before_line, $line_no - $count--;
            }
        }

        if ($option{out_unique}) {
            $match->{$hl->match($line)}++ if ($line);
        }
        elsif ($line) {
            my $last = $hl->get_last_found();
            if ($last) {
                $$out .= $BLUE . $last . $RESET;
            }

            my ( $found, $before, $after, $to ) = $hl->highlight($line);
            if ($found) {
                $$out .= sprintf $REVERSE . $BOLD . $ON_RED . '%4i: ' . $RESET . '%s', $line_no, $found;
            }
            elsif ($before) {
                my $ans = '';
                if ( $answer->{all} ) {
                    $$out .= sprintf $REVERSE . $BOLD . $ON_GREEN . '%4i: ' . $RESET . '%s', $line_no, $after;
                    $post = 1;
                }
                else {
                    $$out .= sprintf $REVERSE . $BOLD . $ON_RED . 'From: ' . $RESET . '%s', $before;
                    $$out .= sprintf $REVERSE . $BOLD . $ON_RED . 'To    ' . $RESET . '%s', $after;
                    print {$fh} $$out;
                    $$out = '';

                    warn Dumper $answer;
                    $ans = lc prompt(-prompt => $RESET . "Change? [yNa] ", -default => 'n', '-1t');
                    print "\n";
                }

                if ( $ans eq 'a') {
                    $answer->{all} = 1;
                    $post = 1;
                }
                if ( $ans eq 'y' || $answer->{all} ) {
                    $stuff{lines}[-1] = $to;
                    $answer->{yes} = 1;
                    #warn $changed;
                    $post = 1;
                }
            }
        }

        if ( $stuff{lines} && @{ $stuff{lines} } ) {
            $content .= join '', @{ $stuff{lines} };
            @{ $stuff{lines} } = ();
        }

        if ( !$line && $out ) {
            save_replace( $last_file, $content, $answer );
            $content = '';
        }

        if ($option{bw}) {
            print {$fh} $$out;
            $$out = '';
        }
        if ( $$out && ( !$option{sre_smart} || (my @tmp = split /\n/, $$out) >= $lines) ) {
            if ($option{sre_smart}) {
                my $tmp;
                $fh = $tmp if open $tmp, '|-', $ENV{CS_PAGER_COLOR} || 'less -Rx4SFX';
            }
            print {$fh} $$out;
            $$out = '';
            $option{sre_smart} = 0;
        }

        return $post;
    };
}

sub save_replace {
    my ( $file, $content, $answer ) = @_;

    # check that we have something to do
    return if !$answer->{yes};

    delete $answer->{yes};

    my $ans = $answer->{save_all} ? 'y' : 'n';
    if ( !$answer->{save_all} ) {
        $ans = prompt "Save changes to $file? [yNa] ", -default => 'n', '-1t';
    }

    if ( $ans eq 'a' ) {
        $answer->{save_all} = 1;
    }
    if ( $ans eq 'y' || $answer->{save_all} ) {
        $file = path($file);

        # Create a backup of the file if we don't appear to be in a revision control system environment
        # TODO make this smarter to check that the files are currently part of the rcs system
        if ( !grep { -d $_ } qw/ .git .bzr .svn CSV RCS / ) {
            my $backup = $file->parent->child($file->basename . '~');
            my $i = 1;
            while (-f $backup) {
                $backup = $file->parent->child($file->basename . '~' . $i++);
            }
            move $file, $backup;
        }

        my $fh = $file->openw;
        print {$fh} $content;
        close $fh;
        $content = '';
        print "Saved $file\n";
    }

    return;
}

sub params {
    my ($name, %var) = @_;
    my %params;

    VAR:
    for my $key (keys %var) {
        next VAR if $key !~ /^ $name _ /xms;
        my $new_key = $key;
        $new_key =~ s/^ $name _ //xms;
        $params{$new_key} = $var{$key};
    }

    return %params;
}

sub parse_config {
    my ($opt) = @_;

    $ENV{HOME} ||= $ENV{USERPROFILE};
    my $conf_file = $opt->{config} || "$ENV{HOME}/.csrc";

    return if !-r $conf_file;

    require Config::General;
    my $conf = Config::General->new($conf_file);
    my %conf = $conf->getall();

    $conf{default} ||= {};
    $conf{project} ||= {};

    my $default = $conf{default};

    my $project =
        $opt->{project} ? $opt->{project}
        : $name ne 'cs' ? $name
        :                 undef;
    if ( $project && $conf{project} && keys %{$conf{project}} && $conf{project}{$project} ) {
        $default = merge($conf{project}{$project} || {}, $default);
    }

    %$opt = %{ merge($default, $opt) };

    return;
}

sub merge {
    my ($hash1, $hash2, @rest) = @_;
    my $merge = {};

    for my $key (uniq sort keys %{$hash1}, keys %{$hash2}) {
        $merge->{$key} =
            exists $hash1->{$key} ? $hash1->{$key}
        :                           $hash2->{$key};
    }

    return merge($merge, @rest) if @rest;

    return $merge;
}

__DATA__

=head1 NAME

cs - Search and/or replace text (with some intelligence)

=head1 VERSION

This documentation refers to cs version 0.7.5.

=head1 SYNOPSIS

   cs [option] search
   cs [option] search -r replace
   cr [option] search replace

 OPTIONS:
  search         A perl regular expression. if it is written in multiple parts
                 eg search this on the command line (ie no joinded together
                 with quotes) the parts will be joined together with \s or
                 if --all is used a regular expression will be written
                 containing each part in every order, if --words the parts are
                 seperated by .*'s.
  replace        The value to substitute for the values found by search

  Search:
   -a --all      Find all parts on regardless of order on the line
   -W --words    Similar to --all but with out the reordering
   -i --ignore-case
                 Turn off case sensitive searching
   -w --whole    Makes the match only whole words (ie wraps with (?<\W) & (?=\W))
   -c --contains[=]re
                 Only show matches if the file also matches this sub regex.
                 This may be declared more that once and the results are ORed.
   -S --not-contains[=]re
                 Ignore any files whoes contents match this regex.
   -m --smart    Converts multi part regexes baised on what is imput
                 eg cs ss Class is converted to cs class Class
                    cs n func                   cs function func
                    cs b subroutine             cs sub subroutine
  Replace:
   -r --replace[=]string
                 String to replace found text with
  Files:
   -p --path[=]string
                 A colon seperated list of directories to search in, which may
                 include globing but you must quote so the shell doesn't do
                 the globbing itself.
                 (Default is current directory)
   -l --follow-symlinks
                 Follow symlinks to directories
      --no-follow-symlinks
                 Don't follow symlinks to directories
      --recurse  Recurse into subdirectories (Default)
      --no-recurse
                 Turns off recursing into subdirectories
   -n --file-include[=]string
                 Only include files mathcing the regex (Multiple)
   -N --int[=]string
      --include-type[=]string
                 Only include files the specified type (Mulitple)
                 see perldoc File::TypeCategories available types
   -x --file-exclude[=]string
                 Don't include files mathcing the regex (Multiple)
   -X --ext[=]string
      --exclude-type[=]string
                 Don't include files the specified type (Mulitple)
                 see perldoc File::TypeCategories available types
      --file-ignore[=]string
                 Replace the default ignore regex
   -d --file-ignore-add[=]string
                 Add this regex to the list of ignored files
   -r --file-ignore-remove[=]string
                 Remove this regex to the list of ignored files
  Output:
   -C --context[=]int
                 Show int lines of context before and after a match
   -B --before[=]int
                 Show int lines before a match
   -A --after[=]int
                 Show int lines after a match
   -t --totals
                 Show the total number of lines & files matched
   -f --files-only
                 Show only the file names containg matches
   -L --last[=][function|class|sub]
                 Show the last function, class or sub name found before the
                 matched line.
   -q --quiet    Turn off warnings about unreadable files & directories.
   -u --unique   Show only unique matches (just the match not the whole line)
      --limit[=]int
                 Only show this number of found search results
  Other:
   -E --execute[=]cmd
                 Run this command with the found files as arguments
   -P --project[=]string
                 Use the specified projects default settings
   -c --config[=]file
                 Use the specified file as the config file instead of the
                 deafult ~/.cs

   -v --verbose  Show more detailed option
      --version  Prints the version information
      --help     Prints this help information
      --man      Prints the full documentation for cs with example usage

=head1 DESCRIPTION

The C<cs> command is aimed at searching large quantities of text files with
the ability to easily select searching files by type (or excluding files of a
certain type). Also by default C<cs> excludes version control directories eg
.svn or .git.

=head2 Examples

 cs --path lib:t query

This would search both the directories lib/ and t/ for files containing the
work query.

 cs --include-type=perl --smart b do_stuff

This would search only perl files (.pl, .pm and files with the first line
containing perl eg #!/usr/bin/perl or #!/usr/bin/env perl) for any declaration
of a subroutine who's name starts with do_stuff eg sub do_stuff_again.

 cs --exclude-type=html input

Would search all non-html files (.html, .htm, .xhtml etc) for the word input

 cs --after 5 text

This would show up to 5 lines of text following any links that match text

 cs --files-oly text

This would show only the names of files that contain text. This can speed
the search considerably as files are stopped being searched after a single
match is found

 cs --unique 'CONST_[A-Z0-9]'

This will search for all upper case words starting with CONST_ and show a
unique list of matched words, no files or matched lines are shown.

=head1 SUBROUTINES/METHODS

=head1 DIAGNOSTICS

=head1 CONFIGURATION AND ENVIRONMENT

A configuration file placed in ~/.csrc (or specified through --conf) allows
allows the setting of default values. See L<Config::General> for full details
of the file format.

Eg

  <default>
      smart = 1
  </default>

  <file_types>
      <perl>
          definite    = [.]pl$  # Definite match regexps can be specified mulitple
          definite    = [.]pm$  # times to form a list of definit matches
          definite    = [.]pod$ # Note this replaces the predefined list
          definite    = [.]PL$

          possible    = [.]t$   # As can possiple matches
          possible    = [.]cgi$

          none        = 1       # set files with out a suffix to match as perl files
          bang        = perl    # Causes the reading of the first line of a file
                                # to check if it contains /perl/ (and there fore matches)
      </perl>
      <python>
          +definite   = [.]pthony$ # Adds this regexp to the default list of
                                   # regexps that definitly phyton files
      </python>
  <file_types>

  <project proj>
    exclude = /path/to/excluded/dir
  </project>

  <project other_work>
    file-exclude = large[.]file$
  </project>

In the C<default> section, default values for command line options can be specified.

In the C<file_types> section, you can add new file types or override or change
existing file types.

In the project section, you can add defaults specific to a project which can
be specified on the command line as --project=proj

=head2 Pager

By default cs uses the command C<less -Rx4SFX> if it can run other wise it
falls back just writing to C<STDOUT>. You can change this environment variable
C<CS_PAGER_COLOR>

=head1 DEPENDENCIES

Some of the --smart capabilities (ie paging output) require the C<less> command
to be installed other wise the paging wont available.

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to Ivan Wills (ivan.wills@gmail.com).

Patches are welcome.

=head1 ALSO SEE

C<grep -r> - Recursive C<grep>, can be much faster but will search into version
control directories and has to be used with C<find> to limit the searched files.

L<ack> - This a very similar in syntax to C<grep> but can't do replacements which
C<cs> can.

=head1 AUTHOR

Ivan Wills - (ivan.wills@gmail.com)

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
All rights reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.

=cut