App-Greple
2 results

 view release on metacpan or  search on metacpan

script/greple  view on Meta::CPAN 

    @ARGV = map { utf8::is_utf8($_) ? $_ : decode('utf8', $_) } @ARGV;

## ~/.greplerc
unless ((@ARGV and $ARGV[0] eq "--norc" and shift)
	or
	($ENV{GREPLE_NORC}) ) {
    $rcloader->load(FILE => "$ENV{HOME}/.greplerc");
}

## modules
$rcloader->deal_with(\@ARGV);

push @optargs, $rcloader->builtins;

## ENV
$ENV{'GREPLEOPTS'} and unshift @ARGV, shellwords($ENV{'GREPLEOPTS'});


## GetOptions
my @SAVEDARGV = @ARGV;
$parser->getoptions(@optargs) || usage();

if ($opt_version) {
    print "$version\n";
    exit 0;
}

our %opt_d;
@opt_d = map { split // } @opt_d;
@opt_d{@opt_d} = @opt_d;

if ($opt_d{o}) {
    warn "\@ARGV = ", join(' ', shellquote(@SAVEDARGV)), "\n";
}

## -m option
my @splicer = (not defined $opt_m) ? () : do {
    my @param = split /,/, $opt_m, -1;
    push @param, '' if @param % 2;
    if (notall { /^(-?\d+)?$/ } @param) {
	die "$opt_m: option format error.\n";
    }
    map {
	my($offset, $length) = @$_;
	if ($length ne '') {
	    sub { splice @{+shift}, $offset || 0, $length }
	} else {
	    sub { splice @{+shift}, $offset || 0 }
	}
    }
    pairs @param;
};

my $file_code;
my $default_icode = 'utf8';	# default input encoding
my @default_icode_list = qw(euc-jp 7bit-jis);
my $output_code;
my $default_ocode = 'utf8';	# default output encoding

$output_code = $opt_ocode || $default_ocode;
binmode STDOUT, ":encoding($output_code)";

## show unused option characters
if ($opt_d{u}) {
    my $s = join('','0'..'9',"\n",'a'..'z',"\n",'A'..'Z',"\n");
    map { /\|([0-9a-zA-Z])\b/ && $s =~ s/$1/./ } @optargs;
    die $s;
}

## show man pages
if ($opt_man or $opt_show or $opt_path) {
    my @module = map {
	/^-M(\w+(::\w++(?![=(]))*)/ ? "App::Greple::$1" : ()
    } @ORIG_ARGV;
    if (@module) {
	my $module = $module[-1];
	my $jp = first { -x "$_/perldocjp" } split /:/, $ENV{PATH};
	my $perldoc = $jp ? "perldocjp" : "perldoc";
	$ENV{PERL5LIB} = join ':', @INC;
	my $file = $module =~ s[::][/]gr . '.pm';
	die unless $INC{$file};
	if ($opt_man) {
	    exec "$perldoc $module" or die $!;
	} else {
	    chomp(my $file = `$perldoc -ml $module`);
	    if ($opt_path) {
		say $file;
	    } else {
		my $pager = $ENV{PAGER} || 'less';
		exec "$pager $file" or die $!;
	    }
	}
	exit;
    }
    pod2usage({-verbose => 2});
    die;
}

sub default_module {
    my $mod = shift;
    my $module = $mod->module;
    return 1 if $module =~ /\b \.greplerc $/x;
    return 1 if $module =~ /\b default $/x;
    return 0;
}

## setup file encoding
if (@opt_icode) {
    @opt_icode = map { split /[,\s]+/ } @opt_icode;
    if (grep { s/^\+// } @opt_icode) {
	unshift @opt_icode, @default_icode_list;
    }
    @opt_icode = uniq @opt_icode;
    if (@opt_icode > 1) {
	@opt_icode = grep { !/(?:auto|guess)$/i } @opt_icode;
	Encode::Guess->set_suspects(@opt_icode);
	$file_code = 'Guess';
    }
    elsif ($opt_icode[0] =~ /^(?:guess|auto)$/i) {
	Encode::Guess->set_suspects(@default_icode_list);
	$file_code = 'Guess';

script/greple  view on Meta::CPAN 

    [ "include" , \@opt_include , 1 ], # need &
    [ "exclude" , \@opt_exclude , 1 ], # need &
    ) {
    my($cat, $opt, $pattern) = @$set;
    for (@{$opt}) {
	next if callable $_;
	/^&\w+/ or next if $pattern;
	$_ = parse_func($_) or die "$cat function format error: $_\n";
    }
}

my $regions = App::Greple::Regions::Holder->new;
for my $set (
    [ \@opt_inside,  REGION_INSIDE  | REGION_UNION     ],
    [ \@opt_outside, REGION_OUTSIDE | REGION_UNION     ],
    [ \@opt_include, REGION_INSIDE  | REGION_INTERSECT ],
    [ \@opt_exclude, REGION_OUTSIDE | REGION_INTERSECT ])
{
    my($opt, $flag) = @$set;
    for my $spec (@$opt) {
	$regions->append(FLAG => $flag, SPEC => $spec);
    }
}

##------------------------------------------------------------

if ($opt_d{m}) {
    warn "Search pattern:\n";
    my $i;
    for my $pat ($pat_holder->patterns) {
	my $type =
	    $pat->is_required ? 'must' :
	    $pat->is_negative ? 'not' :
	    $pat->is_positive ? 'and' : 'else';
	my $target = $pat->regex // $pat->string;
	warn sprintf("  %4s %1s %s\n",
		     $type,
		     $pat->is_function ? '&' : '',
		     @colors > 1 ? index_color($i++, $target) : $target);
    }
    warn sprintf("must = %d, need = %d, allow = %d\n",
		 $count_must, $count_need, $count_allow);
}

## push post-process filter
if (@opt_pf) {
    push_output_filter(\*STDOUT, @opt_pf);
}

usage() and exit if defined $opt_usage;

open SAVESTDIN,  '<&', \*STDIN  or die "open: $!";
open SAVESTDOUT, '>&', \*STDOUT or die "open: $!";
open SAVESTDERR, '>&', \*STDERR or die "open: $!";

sub recover_stdin {
    open STDIN, '<&', \*SAVESTDIN or die "open: $!";
}
sub recover_stderr {
    open STDERR, '>&', \*SAVESTDERR or die "open: $!";
    binmode STDERR, ':encoding(utf8)';
}
sub recover_stdout {
    close STDOUT;
    open STDOUT, '>&', \*SAVESTDOUT or die "open: $!";
}
sub close_stdout {
    close SAVESTDOUT;
    close STDOUT;
}

sub read_stdin { <SAVESTDIN> }

my $slurp = do {
    ##
    ## Setting utf8 warnings fatal makes it easy to find code conversion
    ## error, so you can choose appropriate file code or automatic code
    ## recognition, but loose a chance to find string in unrelated area.
    ##
    if ($opt_error =~ /^(?: fatal | skip | retry )$/x) {
	if ($opt_warn{read}) {
	    sub {
		use warnings FATAL => 'utf8';
		my $stdin = eval { local $/; <STDIN> };
		warn $@ if $@;
		$stdin;
	    }
	} else {
	    sub {
		use warnings FATAL => 'utf8';
		eval { local $/; <STDIN> };
	    }
	}
    } elsif ($opt_error eq 'ignore') {
	if ($opt_warn{read}) {
	    sub { local $/; <STDIN> };
	} else {
	    sub {
		close STDERR;
		my $stdin = do { local $/; <STDIN> };
		recover_stderr;
		$stdin;
	    }
	}
    } else {
	die "$opt_error: invalid action.\n";
    }
};

use Term::ANSIColor::Concise qw(ansi_code);

use constant {
    EL  => ansi_code('{EL}'),    # Erase Line
    ED  => ansi_code('{ED}'),    # Erase Display
    SCP => ansi_code('{SCP}'),   # Save Cursor Position
    RCP => ansi_code('{RCP}'),   # Restore Cursor Position
    DSC => ansi_code('{DECSC}'), # DEC Save Cursor
    DRC => ansi_code('{DECRC}'), # DEC Restore Cursor
    CR  => "\r",
};

script/greple  view on Meta::CPAN 


for (@opt_prologue) { $_->call() }

grep_files();

for (@opt_epilogue) { $_->call() }

if ($opt_d{n}) {
    print STDERR ED;
}

if ($opt_uniqcolor and $opt_d{c}) {
    dump_uniqcolor();
}

## show statistic info
if ($opt_d{s}) {

    $stat{time_end} = [times];
    my @s = $stat{time_start}->@*;
    my @e = $stat{time_end}->@*;
    printf(STDERR "cpu %.3fu %.3fs\n", $e[0]-$s[0], $e[1]-$s[1]);

    local $" = ', ';
    for my $k (sort keys %stat) {
	my $v = $stat{$k};
	print STDERR
	    "$k: ",
	    ref $v eq 'ARRAY' ? "(@$v)" : $v,
	    "\n";
    }
}

close_stdout;

if ($opt_d{p}) {
    open STDOUT, ">&STDERR";
    system "ps -lww -p $$";
    system "lsof -p $$";
}

exit($opt_exit // ($stat{match_effective} == 0));

######################################################################

sub grep_files {
  FILE:
    while (defined($current_file = open_nextfile())) {
	my $content = $slurp->();
	$stat{file_tried}++;
	if (not defined $content) {
	    if ($opt_error eq 'fatal') {
		die "ABORT on $current_file\n";
	    }
	    if ($opt_error ne 'retry') {
		warn "SKIP $current_file\n" if $opt_warn{skip};
		next FILE;
	    }

	    # Try again
	    binmode STDIN, ':raw';
	    seek STDIN, 0, 0 or do {
		warn "SKIP $current_file (not seekable)\n"
		    if $opt_warn{skip};
		next FILE;
	    };
	    $content = $slurp->();
	    if (not defined $content) {
		warn "SKIP* $current_file\n" if $opt_warn{skip};
		next FILE;
	    }
	    warn "RETRY $current_file\n" if $opt_warn{retry};
	    $stat{read_retry}++;
	    binmode STDOUT, ':raw';
	}

	my $matched = grep_data(\$content);

	$stat{match_effective} += $matched;
	$stat{file_searched}++;
	$stat{length} += length $content;
    } continue {
	close STDIN; # wait;	# wait for 4.019 or earlier?
	# recover STDIN for opening '-' and some weird command which needs
	# STDIN opened (like unzip)
	recover_stdin;
	binmode STDOUT, ":encoding($output_code)";
    }
}

sub usage {
    pod2usage(-verbose => 0, -exitval => "NOEXIT");

    my $quote = qr/[\\(){}\|\*?]/;
    for my $bucket ($rcloader->buckets) {
	my $module = $bucket->module;
	print "    $module options:\n";
	for my $name ($bucket->options) {
	    my $help = $opt_usage ? "" : $bucket->help($name) // "";
	    next if $help eq 'ignore';
	    my @option = $bucket->getopt($name, ALL => 1);
	    printf("        %-20s %s\n", $name,
		   $help || join(' ', shellquote(@option)));
	}
	print "\n";
    }

    print "Version: $version\n";

    exit 2;
}

sub open_nextfile {

    ##
    ## --chdir
    ##
    while (@ARGV == 0 and @opt_chdir and (@argv_files or @opt_glob)) {
	my $dir = shift @opt_chdir;
	warn "chdir $dir/\n" if $opt_d{d};
	chdir $start_directory or die "$!: $start_directory\n";
	chdir $dir or die "$!: $dir\n";
	push @ARGV, @argv_files, map(glob, @opt_glob);
    }

    my $file;
    while (defined($file = shift(@ARGV)) ||
	   defined($file = $opt_readlist && read_stdin)) {
	$file = decode 'utf8', $file unless utf8::is_utf8 $file;
	$file =~ s/\n+$//;

	if (0) {}
	elsif ($file =~ /^https?:\/\//) {
	    open(STDIN, '-|') || exec("w3m -dump $file") || die "w3m: $!\n";
	}
	elsif ($file eq '-') {
	    # nothing to do
	}
	else {
	    open(STDIN, '<', $file) or do {
		warn "$file: $!\n" unless -l $file;
		next;
	    };
	}

	if (my @filters = $filter_d->get_filters($file)) {
	    push_input_filter({ &FILELABEL => $file }, @filters);
	}

	if ($file_code eq 'binary') {
	    binmode STDIN, ":raw";
	} else {
	    binmode STDIN, ":encoding($file_code)";
	}

	return $file;
    }
    undef;
}

######################################################################

sub grep_data {
    local *_ = shift;

    ##
    ## --begin
    ##
    for my $f (@opt_begin) {
	eval { $f->call(&FILELABEL => $current_file) };
	if (my $msg = $@) {
	    if ($msg =~ /^SKIP/i) {
		warn $@ if $opt_warn{begin};
		return 0;
	    } else {
		die $msg;
	    }
	}
    }

    $progress_show->() if $progress_show;

    my $grep = App::Greple::Grep->new(
	text         => \$_,
	filename     =>  $current_file,
	pattern      =>  $pat_holder,
	regions      =>  $regions,
	border       =>  $border_re,
	after        =>  $opt_A,
	before       =>  $opt_B,
	only         =>  $opt_o,
	all          =>  $opt_all,
	block        => \@opt_block,
	stretch      =>  $opt_stretch,
	must         =>  $count_must,
	need         =>  $count_need,
	countcheck   =>  $count_match_sub,
	allow        =>  $count_allow,
	strict       =>  $opt_strict,
	group_index  =>  do { local $_ = $opt_colorindex;
			      $opt_capture_group ? /G/i ? /P/i ? 3 : 2 : 1 : 0 },
	region_index =>  $opt_regioncolor,
	stat         => \%stat,
	callback     => \@opt_callback,
	alert_size   =>  $opt_alert{size},
	alert_time   =>  $opt_alert{time},
	join_blocks  =>  $opt_join_blocks,
    )->run;

    ## --postgrep
    for my $f (@opt_postgrep) {
	$f->call($grep);
	# remove emptied results



( run in 0.667 second using v1.01-cache-2.11-cpan-39bf76dae61 )