col_grep

   1 #! /usr/bin/perl
   2 # col_grep greps a column matching a pattern, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: perl_script 1153 2008-04-08 00:04:20Z don $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 col_grep - grep for a column matching a pattern
  18
  19 =head1 SYNOPSIS
  20
  21 col_grep [options] PATTERN [FILE...]
  22 col_grep [options] [-e PATTERN] [FILE...]
  23
  24  Options:
  25   --delimiter, -d Delimiter to use (default tab)
  26   --regexp, -e pattern to match
  27   --fields, -f field number to match (default 1)
  28   --help, -h display this help
  29   --man, -m display manual
  30
  31 =head1 OPTIONS
  32
  33 =over
  34
  35 =item B<--delimiter,-d>
  36
  37 Delimiter to use, defaults to tab
  38
  39 =item B<--regexp, -e>
  40
  41 Pattern to match
  42
  43 =item B<--fields, -f>
  44
  45 Field number to match; starts at 1
  46
  47 =item B<--help, -h>
  48
  49 Display brief useage information.
  50
  51 =item B<--man, -m>
  52
  53 Display this manual.
  54
  55 =back
  56
  57 =head1 EXAMPLES
  58
  59
  60 =cut
  61
  62 use Scalar::Util qw(looks_like_number);
  63 use Text::CSV;
  64 use vars qw($DEBUG);
  65
  66 my %options = (debug            => 0,
  67                help             => 0,
  68                man              => 0,
  69                delimiter        => "\t",
  70                field            => [],
  71                regexp           => [],
  72                has_header       => 0,
  73               );
  74
  75 GetOptions(\%options,
  76            'delimiter=s',
  77            'field|f=s@',
  78            'regexp|e=s@',
  79            'has_header|has-header!',
  80            'debug|d+','help|h|?','man|m');
  81
  82 pod2usage() if $options{help};
  83 pod2usage({verbose=>2}) if $options{man};
  84
  85 $DEBUG = $options{debug};
  86
  87 my @USAGE_ERRORS;
  88 # if (1) {
  89 #      push @USAGE_ERRORS,"You must pass something";
  90 # }
  91
  92 if (not @{$options{field}}) {
  93     $options{field} = [1];
  94 }
  95
  96 my @header;
  97 my %header;
  98 if ($options{has_header}) {
  99     # we allow for a header
 100 }
 101
 102 my @field_indexes = map { looks_like_number($_) && $_ > 0 ? $_ - 1 : $_;}
 103     map {split /,/} @{$options{field}};
 104 my %field_indexes;
 105 @field_indexes{@field_indexes} = @field_indexes;
 106 @field_indexes = values %field_indexes;
 107
 108 if (grep {not /-?\d+/} @field_indexes and not $options{has_header}) {
 109     push @USAGE_ERRORS,"Invalid field index(es)";
 110 }
 111
 112 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
 113
 114 if (not @{$options{regexp}} and @ARGV) {
 115     push @{$options{regexp}}, shift @ARGV;
 116 }
 117
 118 if (not @ARGV) {
 119     # we'll use this as a special indicator to read stdin
 120     push @ARGV,undef;
 121 }
 122 my %compiled_regexes;
 123 my $csv = Text::CSV->new({sep_char=>$options{delimiter}});
 124 FILE: for my $file (@ARGV) {
 125     my $fh;
 126     my $headers_updated = 0;
 127     if (not defined $file) {
 128         $fh = \*STDIN;
 129         $file = "STDIN";
 130     } else {
 131         $fh = IO::File->new($file,'r') or
 132             die "Unable to open $file for reading: $!";
 133     }
 134  LINE: while (<$fh>) {
 135         my $chomped = chomp;
 136         my $line = $_;
 137         die "Unable to parse line $. of $file: ".$csv->error_diag() unless $csv->parse($_);
 138         my @fields = $csv->fields();
 139         # skip lines which don't have enough fields
 140         if ($options{has_header} and not @header) {
 141             @header = @fields;
 142             @header{@header} = 0..$#fields;
 143             print $line;
 144             print $/ if $chomped;
 145             next LINE;
 146         }
 147         if ($options{has_header} and not $headers_updated) {
 148             $headers_updated = 0;
 149             if (@header < @fields) {
 150                 @header{@header} = 1..@fields;
 151             }
 152             my @new_indexes;
 153             for my $index (@field_indexes) {
 154                 push @new_indexes,$index and next if $index =~ /^-?\d+$/;
 155                 if (not exists $header{$index}) {
 156                     use Data::Dumper;
 157                     print STDERR Dumper(\%header);
 158                     print STDERR "Invalid header $index\n";
 159                     exit 1;
 160                 } else {
 161                     push @new_indexes,$header{$index};
 162                 }
 163             }
 164             @field_indexes = @new_indexes;
 165         }
 166         next LINE if grep {not defined $_} @fields[@field_indexes];
 167     REGEX: for my $regex (@{$options{regexp}}) {
 168         FIELDS: for my $field (@fields[@field_indexes]) {
 169                 if (length $regex) {
 170                     if (not exists $compiled_regexes{$regex}) {
 171                         $compiled_regexes{$regex} = qr/$regex/;
 172                     }
 173                     $field =~ $compiled_regexes{$regex} or next LINE;
 174                 }
 175             }
 176         }
 177         print $line;
 178         print $/ if $chomped;
 179     }
 180 }
 181
 182 __END__