#!/usr/local/bin/perl

$VERSION = '1.04';

use warnings; use strict;

##  NAME:  parse-index
##
##  AUTHOR:  Parv, parv UNDERSCORE  AT yahoo DOT com
##  MODIFIED:  Feb 28 2006
##
##  LICENSE:  Free to use as you please w/ proper credit given.  use at your
##  own risk.  All responsibility for potential damage, loss, etc. is
##  disclaimed.
##
##  PURPOSE:  To search and present freebsd ports INDEX* without make or with
##  the restriction of being in /usr/ports by w/ help of Perl (like) regular
##  expressions.
##
##  USAGE:
##    To search for 'twm', 'vtwm', or 'tvtwm' in comments...
##
##      parse-index -comment '\bt?v?twm'
##
##   ...To see whole index...
##
##      parse-index -show
##
##   ...See "parse-index -usage" for details
##

use Pod::Usage;
use Getopt::Long qw( :config default );

use List::Util qw( first max );

#  Index layout (all on one line in order); when in doubt, defer to
#  /usr/ports/Mk/bsd.port.mk ( describe target) See also:
#  http://www.FreeBSD.org/cgi/cvsweb.cgi/ports/Mk/BSD.port.subdir.mk?rev=1.55&content-type=text/x-cvsweb-markup
#  ----
#  distribution-name|port-path|installation-prefix|comment|description-file\
#  |maintainer|categories|build deps|run deps|www site|extract deps\
#  |patch deps|fetch deps
#  ----
my %Fields =
  (
    #  Names, in order, of the fields of a record
    'all'  => [ qw{ name  origin  install-prefix
                    comment  description maintainer
                    category
                    build-dep run-dep
                    uri
                    extract-dep patch-dep fetch-dep
                  }
              ]

  #  Fields which can have multiple entries
  , 'multi'  =>
      qr/^(?: category |
            (?: fetch | extract | patch | build | run) -dep
          )
        /x

  #  Fields to ignore if/when searching
  , 'skip'  =>  qr/^(?: install-prefix | description )/x
  );

#  Length of the longest field name
$Fields{'max-length'} = max map length $_ ,  @{ $Fields{'all'} };

#  Number of fields
$Fields{'count'} = scalar @{ $Fields{'all'} };

#  Fields to keep, to be used as search options
$Fields{'keep'} =
  \join( '|'
        , grep { $_ !~ m/$Fields{'skip'}/ } @{ $Fields{'all'} }
       );

#  Default options - controlling overall behaviour
my $Configure =
  { 'usage'  => 0

  #  Directory where ports tree is installed
  , 'dir'  => defined $ENV{PORTSDIR} ? $ENV{PORTSDIR} : '/usr/ports'

  , 'index' => 'INDEX' . os_version_to_suffix()

  #  To-be-compiled regex to search for
  , 'what'  => ''

  #  Field to search in (if not 'show' whole index),
  , 'find'  =>  [ 'name'
                #  Regex to be compiled
                , join '|' , qw( show any)  , ${ $Fields{'keep'} }
                ]
  };

$Configure->{'find'}->[1] = qr/^ $Configure->{'find'}->[1] /xi;

#  Update $Configure w/ any user specified options
$Configure = get_config( $Configure );

#  Compile regex
$Configure->{'what'} = qr/$Configure->{'what'}/i;


handle_search( $Configure , 'print' );
exit;

sub handle_search
{
  my ( $conf , $do_what ) = @_;

  #  If not printing, then we will pass the processed index
  $do_what = 'pass' unless $do_what eq 'print';

  my $index = join '/' , $conf->{dir} , $conf->{'index'};
  die "$index is unreadable\n" unless -r $index;

  #  Used only when printing is not specified
  my @processed;

  #  Print or save record processed records

  search
  ( 'type'    => $conf->{'find'}->[0]
  , 'string'  => $conf->{'what'}
  , 'index'   => $index
  , 'process' =>
      $do_what eq 'print'
      ? sub { print @{ $_[0] }; }
      : sub { push @processed , @{ $_[0] }; }
  );

  return unless $do_what eq 'print';
  return \@processed;
}

sub search
{
  my %opt = @_;

  my $index = $opt{'index'};
  open INDEX , '<', $index or die "Could not open $index: $!\n";

  #  Choose sub based on given search criteria
  my $real_search = make_search( $opt{'type'} );

  while ( <INDEX> )
  {
    chomp;

    my ( $items , $name ) = field_values( $_ );
    next unless $items and $real_search->( $opt{'string'} , $name );

    $opt{'process'}->( pretty_record( $name ) );
  }

  close INDEX or die "could not close $index: $!\n";
  return;
}

sub make_search
{
  my ( $type ) = @_;
  return
      $type eq 'show'     ? sub { 1 }
    : $type eq 'any'      ? search_any_field( $type )
    : $type eq 'depend'   ? search_depend( $type )
                          : search_given_field( $type )
    ;
}

sub search_given_field
{
  my ( $type ) = @_;
  return
    sub {
          my ( $re , $h ) = @_;
          return 0 unless exists $h->{$type};
          return
            first { m/$re/ }
              ref $h->{$type} ? @{ $h->{$type} } : $h->{$type}
            ;
        };
}

sub search_any_field
{
  my ( $type ) = @_;
  return
    sub {
          my ( $re , $h ) = @_;
          return first { m/$re/ } values %{ $h };
        };
}

#  NEEDS WORK
sub search_depend
{
  my ( $type ) = @_;
warn "searching for dependencies...";
  return
    sub {
          my ( $re , $h ) = @_;
          return
            first { m/$re/ } grep m/-dep/ , @{ $Fields{'all'} };
            ;
        };
}

#  Return pretty up record from record hash ref
sub pretty_record
{
  my $rec = shift;

  my $value = sub {
                    my $val = shift;
                    return ref $val ne 'ARRAY' ? $val : @{ $val } ;
                  };
  my @rec;
  #  Create array elements either for printing or passing
  foreach my $key ( @{ $rec->{'Ordered'} } )
  {
    push @rec
    , map sprintf( "%$Fields{'max-length'}s:  %s\n" ,  $key , $_ )
      , $value->($rec->{$key})
      ;
  }

  push @rec , "\n";
  return \@rec;
}

#  Return fields number & hash ref of a record keyed by value type
sub field_values
{
  my $rec = shift;

  #  Get elements
  my @values = split '\|' , $rec , $Fields{'count'};
  my $found = scalar @values;
  my %pairs = ();

  #  Needs to be >=10 values may be whether empty, but not undefined
  unless ( $Fields{'count'} == $found )
  {
    warn<<_WARN_;
$rec
  is ill formed; fields needed: $Fields{'count'} , found: $found
_WARN_

    return (0 , \%pairs);
  }

  #  Fill %pairs w/ field element names & values
  foreach my $idx ( 0 .. $found -1 )
  {
    next if $values[ $idx ] =~ m/^\s*$/;

    #  Save order of keys
    push @{ $pairs{'Ordered'} } , $Fields{'all'}->[ $idx ];

    #  Create key/value pair
    $pairs{ $Fields{'all'}->[$idx] } = $values[ $idx ];
  }

  #  Change multiple-values in to array
  foreach ( keys %pairs )
  {
    #  Skip single item value/key
    next unless $_ =~ m/$Fields{'multi'}/;

    $pairs{$_} = [ split /\s+/ , $pairs{$_} ];
  }
  return
    ( scalar( keys %pairs ) -1 # "Ordered" key doesn't count
    , \%pairs
    );
}

#  Get options
sub get_config
{
  my ( $conf ) = @_;

  GetOptions
  (
    'usage|help'  => \$conf->{'usage'}

  , 'dir=s'       => \$conf->{'dir'}
  , 'index=s'     => \$conf->{'index'}

  , 'find=s'   => \$conf->{'find'}->[0]
  , 'class|category'  =>
      sub{ $conf->{'find'}->[0] = 'category'; }
  , 'show'      => sub{ $conf->{'find'}->[0] = 'show'; }
  , 'any'       => sub{ $conf->{'find'}->[0] = 'any'; }
  , 'name|port' => sub{ $conf->{'find'}->[0] = 'name'; }
  , 'origin'    => sub{ $conf->{'find'}->[0] = 'origin'; }
  , 'comment'   => sub{ $conf->{'find'}->[0] = 'comment'; }

  , 'extract|extract-dep' =>
      sub { $conf->{'find'}->[0] = 'extract-dep'; }

  , 'fetch|fetch-dep' => sub { $conf->{'find'}->[0] = 'fetch-dep'; }
  , 'patch|patch-dep' => sub { $conf->{'find'}->[0] = 'patch-dep'; }
  , 'build|build-dep' => sub { $conf->{'find'}->[0] = 'build-dep'; }
  , 'run|run-dep'     => sub { $conf->{'find'}->[0] = 'run-dep'; }
  , 'dep|depend'      => sub { $conf->{'find'}->[0] = 'depend'; }
  )
  || die pod2usage( '-exitval'  => 1 , '-verbose'  => 0 ) ;

  pod2usage( '-exitval'  => 0 , '-verbose'  => 3 ) if $conf->{'usage'};

  pod2usage( '-message' => "either specify to show the whole index or type of search to do\n"
            , '-exitval' => 1 , '-verbose' => 0
           )
    if ( $conf->{'find'}->[0] eq 'show' && scalar @ARGV )
    || ( $conf->{'find'}->[0] ne 'show' && !scalar @ARGV );

  #  Regex to search for
  $conf->{'what'} = join '|' , @ARGV if scalar @ARGV;
  return $conf;
}

#  Return major FreeBSD version.
sub os_version_to_suffix
{
  my $version = qx/uname -r/ or die "cannot execute 'uname -r': $!";
  $version =~ m/^(\d+)/;
  return $1 <= 4 ? '' : '-' . $1;
}

__DATA__

=head1 NAME

  parse-index - search and browse the FreeBSD ports INDEX*

=head1 SYNOPSIS

  parse-index -usage

  parse-index -show

  parse-index [ -port ] pattern

  parse-index [ -any | -comment | -port | -origin | -class
                | -find=<too many options to list>
              ]
              pattern

=head1 DESCRIPTION

Parse-index eases searching & browsing of I<FreeBSD Ports INDEX*>
(without make(1) and without the restriction of being in F</usr/ports>)
with help of Perl regular expressions.

To search for a port (name), just specify a pattern; there is no pressing
need to specify B<-port> or B<-find=port> option.

The given arguments/patterns separated by spaces/tabs are turned into an
OR'd regex.  To avoid this behaviour, protect the spaces.  In other
words, take care to avoid shell interpretation.

=head1 OPTIONS

=over 2

=item B<-usage>

Show this message; overrides any other option.

=item B<-dir>=I<ports tree location>

Specify ports tree directory.

If unspecified, I<PORTSDIR> environment variable is checked.  If this is
also unspecified, F</usr/ports> is used as the default.

This option overrides I<PORTSDIR> which overrides default F</usr/ports>.

=item B<-index>=I<name of index file>

Specify name of the index file.  Mind you that this is a file name not
a file path (at least for now).

=item B<-show>

=item B<-any>

=item B<-name>

=item B<-origin>

=item B<-comment>

=item B<-class>

=item B<-find>=I<show>|I<any>|I<name>|I<origin>|I<comment>|I<class>|I<category>

=item B<-find>=I<maintainer>|I<build-dep>|I<run-dep>|I<uri>

Specify what to do, or where search in for given (command line)
argument(s).

=over 2

=item B<show>

show the whole index.

=back

(Below are proper search options which define, for given arguments, the
field (singular) to search for all the ports.  Their purpose are explicitly
listed for completeness sake even if that is blatantly obvious.)

=over 2

=item B<any>

search anywhere in a port's record.

=item B<name>

search in port name.

this option is assumed when any other options are missing and at least an
argument (to search for) is given.

=item B<origin>

search in origin (I<bsd.port.mk> lists it as "port path").

=item B<comment>

search in (one line) comment.

=item B<maintainer>

search from maintainer (e-mail address).

=item B<class> | B<category>

search for the categories in which a particular port, well, has been
categorized.

=item B<build-dep>

search build dependencies.

=item B<run-dep>

search run time dependencies.

=item B<uri>

search for unique resource identifier, URI (web or FTP address for
example).

=back

=back

=head1 ENVIRONMENT

=over 2

=item I<PORTSDIR>

Environment variable pointing to the location of ports tree.

=back

=head1 FILES

=over 2

=item F</usr/ports>

Default location of ports tree.

=item F</usr/ports/INDEX>

Default index file for FreeBSD [34].x.

=item F</usr/ports/Mk/bsd.port.mk>

just read it to see what it does.

=back

=head1 DEPENDENCIES

This program requires L<List::Util> module, a standard module in Perl 5.8.7.

=head1 BUGS

Dependency search does not work right now.

=head1 SEE ALSO

I<FreeBSD::Ports> - More flexible Module similar to this program

I<pkg_info>(1), I<ports>(7)
I<pkg_version>(1), I<portupgrade>(1), I<pkg_tree>(7)

FreeBSD ports collection: http://www.freebsd.org/ports/

=head1 Author, Distribution and such

Parv, parv(at)pair(dot)com

Version:  1.04

ModifieD:  Feb 28 2006

Free to use as you please w/ proper credit given.  Use at your own risk.
All responsibility for potential damage, loss, etc. is disclaimed.

=cut