#!/usr/local/bin/perl

use warnings;
use strict;

##  name:  parse-index.perl
##
##  version:  0.025 -- feb 10 2003
##
##  author:  parv, parv UNDERSCORE fm AT emailuser DOT net
##
##  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.perl -comment '\bt?v?twm'
##
##   ...to see whole index...
##
##      parse-index.perl -show
##
##   ...see "parse-index.perl -usage" for details
##

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

use Pod::Usage;

#  location where non-default modules live
use lib '/home/parv/comp/perl.mod';
use Util qw( if_match check_hash max_length );

#  index layout (all on one line in order)
#  when in doubt, defer to /usr/ports/Mk/bsd.port.mk ( describe target)
#  ----
#  distribution-name|port-path|installation-prefix|comment|description-file\
#  |maintainer|categories|build deps |run deps|www site
#  ----
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
                    }
                ]

     #  fields which can have multple enteries
     , 'multi'  => qr/^(?: category | build-dep | 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_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'

      #  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_index( $Configure , 'print' );


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

  { my @err = check_hash( $conf );
    die ${$err[1]} , "\n" unless $err[0];
  }

  my $index = join '/' , $conf->{dir} , $conf->{'index'};

  die "$index is unreadable\n" unless -r $index;

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

  #  'find' sub to match if asked
  #
  my $where = $conf->{'find'}->[0];

  my $find =
    ( $where eq 'show' )
    ? sub { 1; }
    : ( $where eq 'any' )
      ? #  try to match pattern w/ contents of ANY of the fields
        sub
        { my ($re , $h) = @_;
          return
            if_match( $re , [ map { $h->{$_} } keys %$h ] );
        }
      : #  try to match pattern w/ contents of a PARTICULAR field
        sub
        { my ($re , $h) = @_;

          return if_match( $re , $h->{$where} )
            if exists $h->{$where};

          return 0;
        };

  #  used only when printing is not specified
  my @processed = ()
    if $do_what ne 'print';

  #  print or save record processed records
  #
  my $rec_do = ( $do_what eq 'print' )
               ? sub { print @{ $_[0] }; }
               : sub { push @processed , @{ $_[0] }; };

  open( INDEX , '<', $index )
    || die "could not open $index: $!\n";

  while ( <INDEX> )
  { chomp;
    my ($items , $name) = field_values($_);

    next
      unless $items and $find->( $conf->{'what'} , $name );

    #  print|save records
    $rec_do->( pretty_record($name) );
  }

  close(INDEX) || die "could not close $index: $!\n";

  return \@processed if $do_what ne 'print';
  return;
}

#  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 illformed; fields needed: $Fields{'count'} , found: $found
_WARN_

    return (0 , \%pairs);
  }

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

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

    #  crearte 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 = shift;

  { my @err = check_hash( $conf );
    die ${$err[1]} unless $err[0];
  }

  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'     => sub{ $conf->{'find'}->[0] = 'name'; }
             , 'origin'   => sub{ $conf->{'find'}->[0] = 'origin'; }
             , 'comment'  => sub{ $conf->{'find'}->[0] = 'comment'; }
            )
        || 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;

  check_config($conf);

  return $conf;
}

sub check_config
{
  my $conf = shift;

  { my $message = '';  #  message collector for messages

    #  check for (correct) options
    foreach my $k (keys %$conf)
    {
      next unless ref $conf->{$k} eq 'ARRAY';

      #  collect error messages for wrong options
      #  ----
      #  first element is the default/given option,
      #  2d is regex of allowable options
      #  ----
      $message .= "incorrect option '" . $conf->{$k}->[0] . "' given\n"
        unless $conf->{$k}->[0] =~ m/ $conf->{$k}->[1] /x;
    }

    die pod2usage( '-message' => $message , '-exitval' => 1
                 , '-verbose' => 0
                )
      if length $message;
  }

  return;
}

__DATA__

=head1 NAME

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

=head1 SYNOPSIS

  parse-index.perl -usage

  parse-index.perl -show

  parse-index.perl [ -port ] pattern

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

=head1 DESCRIPTION

Parse-index.perl 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> envrionment 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 balatantly 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 ther 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 catgeories 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 adderss 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 SEE ALSO

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 UNDERSCORE fm AT emailuser DOT net

version:  0.025 -- feb 10 2003

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