#!/usr/local/bin/perl -w

use strict;

##  author:  parv, parv UNDERSCORE fm AT nospammail DOT net
##  date:  dec 23 2002
##  version:  0.021
##
##  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.
##
##  name:  listpkg.perl
##
##  purpose:  print port/package name & location, mainly, for maintenance
##    purposes; like pkg_delete, or to parse '+CONTENTS', etc.
##
##  usage:
##    listpkg.perl -usage | ${PAGER:-more}
##    perldoc listpkg.perl
##
#

#  bring in Getopt module to deal w/ sort order & description
use Getopt::Long qw/:config default/;

##  set default options; otherwise set to user defined values
##  set_chk_opt() returns hash reference
#
my $opt = set_chk_opt();

##  basic port structure
my $DB = { #  package database directory
           base =>  $opt->{dbdir}

           , regex => { origin => qr{ ^\@comment \s+ ORIGIN:
                                      ( [[:alpha:]] .+ ) $ }x
                      }

           #  file names containing information about each port
           , port => { #  dependencies, installed files, origin
                       info    => '+CONTENTS'

                       #  list of ports needing a port; optional
                       , reqd_by => '+REQUIRED_BY'

                       #  description: short comment & a paragraph lengths
                       , descr   => { long => '+DESC' , short => '+COMMENT' }
                    }
         };


##  preparation for printing list

#  create port regex; default is any port starting w/ any of digits and
#  alphas, [[:alnum:]];  for en_US.ISO8859-1 locale, it's [a-zA-Z0-9]
#
my $ports_expect = scalar(@ARGV) ? join('|', @ARGV) : '^[[:alnum:]]';

## print
print_info( $DB->{base}
           , $opt
           , get_port_list( $DB , $opt , qr{$ports_expect} )
          );


##  subroutines

#  returns a hash ref of optionally filtered port list
sub get_port_list
{
  # basic port db layout
  my $DB = shift;

  # options
  my $opt = shift;

  #  pattern to filter ports list
  my $filter = shift;

  return
    unless defined $filter
      or ref $opt eq 'HASH' or ref $DB eq 'HASH';

  #  save list of existing ports related w/ $filter
  opendir(DIR, $DB->{base}) || die "cannot open $DB->{base}: $!\n";

    #  get ports list; port name+version is the directory name
    my @ports =
        grep { -d "$DB->{base}/$_"  && $_ !~ m/^[.]/ }
           readdir(DIR);

  closedir(DIR) || die "cannot close $DB->{base}: $!\n";

  #  filter ports' list based on find option specified
  my $list_filter =
      ($opt->{find}->[0] eq 'port')
      ? sub { my ($port , undef  ) = @_; $port   =~ m/$filter/; }
      : sub { my (undef , $origin) = @_; $origin =~ m/$filter/; };

  #  hash containing port origin & port name
  #  3rd element, ${$DB}{base}/<port>, will be manufactured
  #  as needed outside of the hash
  #
  my %port_list;

  foreach ( @ports )
  { #  get_info() currently returns only origin of a port,
    #  nothing more
    my $origin = %{ get_info($DB , $_) }->{origin};

    next unless $list_filter->($_, $origin);

    $port_list{$_} = $origin || '--';
  }

  return \%port_list;
}

#  return port information gleaned from ${$DB}{base}{Contents}
sub get_info
{
  my $DB = shift;
  my $port = shift;

  return unless ref $DB eq 'HASH' and defined $port;

  #  create complete path for a port's info:
  #    base dir, port name, info (installed file, origin, etc.)
  #
  my $file = join('/' , $DB->{base} , $port, $DB->{port}->{info});

  my %info;

  unless ( defined open(FILE , '<' , $file) )
  { warn "cannot open $file: $!\n"; return; }

    while ( defined (my $line = <FILE>) )
    {
      if ( $line =~ m/$DB->{regex}->{origin}/ )
      {
        $info{origin} = $1;
        last;
      }
    }

  close (FILE) || die "cannot close $file: $!\n";

  return \%info;
}

#  print port information
sub print_info
{
  my ($base_dir , $opt , $port_list) = @_;

  unless ( $base_dir && ref $opt eq 'HASH' && ref $port_list eq 'HASH' )
  {
    die <<_DIE_;

 print_info\(): irregular amount of information given to be printed ...
   i was expecting:
     - a ports db directory,
     - a ports hash reference,
     - a option hash referernce.
_DIE_
  }

  #  finally, print listing as...
  #    <port origin>  <port>  $Port_DB/<port>
  #
  die "print_info\(): sort order is undefined.\n"
    unless defined $opt->{sort};

  #  get the longest port name length & longest origin length
  #  to be used in printf()
  #
  my ($name_max, $origin_max) = ( max_len( [ keys %{$port_list} ] )
                                 , max_len( [ values %{$port_list} ] )
                                );

  #  set default lengths if max_len() returned undef
  $name_max   ||= 38;
  $origin_max ||= 34;

  #  based on $opt->{show_dbdir}, choose one of two
  #  formatted print sub refs
  #
  my $printf =
      $opt->{show_dbdir}
      ? #  print port origin, name/version, PKG_DBDIR
        sub
        { printf "%-${origin_max}s   %-${name_max}s   %s\n" ,
                 ( $port_list->{$_} ,  $_ ,  "${base_dir}/${_}" );
        }
      : #  print port origin, name/version
        sub
        { printf "%-${origin_max}s   %-${name_max}s\n" ,
                 ( $port_list->{$_} ,  $_ );
        };

   #  based on $opt->{sort}->[0], sort by port or origin
   my $sort =
       ($opt->{sort}->[0] eq 'port')
       ? sub
         { lc($a) cmp lc($b) || $a <=> $b }
       : sub
         { lc($port_list->{$a}) cmp lc($port_list->{$b})
           || $port_list->{$a} <=> $port_list->{$b}
         }
       ;

  $printf->() foreach sort { $sort->() } keys %{$port_list};
}


#  return length of the longest string of an array (ref)
sub max_len
{
  my $array = shift;
  return unless scalar @$array;

  #  get the length of the longest string
  return length( (sort {length($b) <=> length($a)} @{$array} )[0] );
}


#  set default options; get user specified ones
sub set_chk_opt
{
  #  set to default options
  my $opt = default_opt();

  #  get options or die w/ usage()
  GetOptions( 'usage|help'   => \$opt->{usage}

              , 'dbdir=s'    => \$opt->{dbdir}
              , 'show-dbdir' => \$opt->{show_dbdir}

              , 'descr=s'             => \$opt->{descr}->[0]
              , 'short|small|terse'   => sub { $opt->{descr}->[0] = 'short' }
              , 'long|large|verbose'  => sub { $opt->{descr}->[0] = 'long'  }

              , 'sort|order=s'  => \$opt->{sort}->[0]
              , 'sort-port'     => sub { $opt->{sort}->[0] = 'port'   }
              , 'sort-origin'   => sub { $opt->{sort}->[0] = 'origin' }

              , 'in=s'    => \$opt->{find}->[0]
              , 'find=s'  => \$opt->{find}->[0]

              , 'in-port|find-port'  =>
                   sub { $opt->{find}->[0] = 'port'   }

              , 'in-origin|find-origin'  =>
                   sub { $opt->{find}->[0] = 'origin' }
            )
    || die usage(1);

  #  show usage & exit normally
  usage(0) if $opt->{usage};

  #  exit if given dbdir isn't a readable directory
  die "'$opt->{dbdir}' is not a readable ports database directory.\n"
    unless -d $opt->{dbdir}
       and -r $opt->{dbdir};

  #  override search criteria if @ARGV is empty/undefined
  #  ( i.e. after option processing, there must be at least
  #   one value in @ARGV to be used a port origin )
  #
  $opt->{find}->[0] = default_opt('find')
    unless scalar @ARGV;

  #  check st options which are not true/false
  #  if any is invalid, set to default
  #
  $opt = check_multi_opt($opt);

  return $opt;
}

#  after GetOptions(), check options
sub check_multi_opt
{
  my $opt = shift;

  #  check if $opt is a valid hash (ref) or not
  die "check_multi_opt: given hash reference is not.\n"
    unless keys %$opt;

  foreach ( keys %$opt )
  {
    #  check only those options which have array ref
    next unless ref $opt->{$_} eq 'ARRAY';

    #  set default option if doesn't match allowable regex
    #  $1, default, comes from the regex
    #
    $opt->{$_}->[0] = $1
      unless $opt->{$_}->[0] =~ m@ $opt->{$_}->[1] @x;
  }

  return $opt;
}

#  return default option(s)
sub default_opt
{ #  default options
  my %default = ( #  don't show usage
                  usage  => 0

                  #  installed ports database directory
                  , dbdir  => (defined $ENV{PKG_DBDIR})
                             ? $ENV{PKG_DBDIR} : '/var/db/pkg'

                  #  don't show $dbdir
                  , show_dbdir  => 0

                  #  don't show any description
                  , descr  => [ 'none' , qr/^(?:(none)|short|long)/ ]

                  #  search criterion
                  , find  => [ 'port' , qr/^(?:(port)|origin)/ ]

                  #  sort criterion
                  , sort  => [ 'port' , qr/^(?:(port)|origin)/ ]
                );

  #  return the complete hash ref in absence of any parameters
  return \%default
    if scalar @_ != 1;

  #  return a single option value
  my $opt = shift;

  if ( exists $default{$opt} )
  {
    #  return 1st element, default option, if key refers to array
    return $default{$opt}->[0]
      if ref $default{$opt} eq 'ARRAY';

    #  return simple data
    return $default{$opt};
  }

  return;
}

# usage
sub usage
{
  # simplified File::Basename::basename() to get program name
  ( my $name = $0 ) =~ s#^.*?([^/]+)$#$1#;

  #  select exit code; 0 (ok, stdout), if not 1 (bad, stderr)
  my $rc = shift;
  $rc = 1 unless $rc == 0;

  #  select output file descriptor (for printing)
  select ( !$rc ? \*STDOUT : \*STDERR );

  while (<DATA>)
  {
    # show only upto SYNOPSIS
    last if $rc && /^=head.+DESCRIPTION/o;

    #  skip pod section markers & one next line
    if ( m{ ^= (?: cut | over | back | for | begin | end ) }x )
    {
      seek DATA, 1, 1;
      next;
    }

    #  strip pod section markers
    if ( m{ ^= (?: head \d \s+ | item ) .*$ }x )
    {
      s{ ^= (?: head \d \s+ | item ) (.*)$ }/$1/x;

       #  skip netx line; empty a/c to perldoc
       seek DATA, 1, 1;
    }

    # strip some pod phrase foramatting
    s/(?:[IBSCFXZ]<([^>]+)>)/$1/g;

    print;
  }

  exit $rc;
}

__DATA__

=head1 NAME

  listpkg.perl - List port name & origin installed via freebsd ports

=head1 SYNOPSIS

  listpkg.perl -usage

  listpkg.perl [ -show-dbdir ]
               [ -dbdir=<installed package database directory> ]
               [ -descr=<none | short | long> ]
               [ -find=<port | origin> ]
               [ -sort=<port | origin> ]
               [ pattern ]

=head1 DESCRIPTION

  Listpkg.perl produces port lists installed via freebsd ports.  First
  column contains the port origin, second port name, and optional third
  column has port name prepended with the installed package database
  directory.

  Optional port names can be specified as a perl regular expression.  If
  missing, a listing of ports will be created which start with any of
  digits and alphas characters, [[:alnum:]]. For en_US.ISO8859-1 locale,
  it's [a-zA-Z0-9].

  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 1

=item  B<-usage>

    Show this message.  It overrides any other option.

=item  B<-dbdir>=I<package database directory>

    Specify installed package database directory.

    If unspecified, PKG_DBDIR envrionment variable is checked.  If this
    is also unspecified, /var/db/pkg is used as the default.

    -dbdir option overrides PKG_DBDIR which overrides default
    /var/db/pkg.

=item  B<-show-dbdir>

    Show ports package database directory along with installed
    port's name/version

=item  B<-in-port>

=item  B<-find-port>

=item  B<-in-origin>

=item  B<-find-origin>

=item  B<-in>=I<port>|I<origin>

=item  B<-find>=I<port>|I<origin>

    Specify search preference.

    port:    Default.  Listing is searched by port name.

    origin: Listing is searched by port origin.

Mind that a option like I<-find=port> can be specified as I<-in=port>,
I<-find-port>, or I<-in-port>; similarly for the I<origin> option.


=item  B<-sort-port>, B<-sort-origin>

=item  B<-sort>=I<port>|I<origin>

    Specify sort, case insensitive, preference.

    port, sort-port:    Default.  Listing is sorted by port name.

    origin, sort-origin: Listing is sorted by port origin.  It makes for
                         slower output (than -sort-port).

=item  B<-short>, B<-long>

=item  B<-descr>=I<none>|I<short>|I<long>

    TO BE IMPLEMENTED.  Specify whether to print any, short, or long port
    description.

    none:   Default.  Don't print any port description.

    short:  Short port description would be printed ('+COMMENT' file).

    long:   Long port description would be printed ('+DESC' file).

=back

=head1 EXAMPLES

  - To list all the ports beginning w/ any of [[:alnum:]] characters...

      listpkg.perl

  - To list ports matching a particular perl regex...

      listpkg.perl .\*font
      listpkg.perl fvwm t?vtwm

  ...in the second example, final regex will be (fvwm|t?vtwm) for which
  ports will be searched.

  - To list port sorted by port origin...

      listpkg.perl -sort=origin 'ruby|perl'

=head1 ENVIRONMENT

  PKG_DBDIR  Specifies alternate location of installed package database.
             It is overridden by -dbddir option.  Default is /var/db/pkg.

=head1 FILES

  /var/db/pkg  Default location of the installed package database.

  /var/db/pkg/port/+COMMENT
               File containing a port's short description, usually a line.

  /var/db/pkg/port/+CONTENTS
               File containing a port's dependency list, installed files,
               deinstall & install scripts, etc.

  /var/db/pkg/port/+DESC
               file containing a port's longer description.

  /var/db/pkg/port/+REQUIRED_BY
               File containing list of ports which require the port in
               question.

=head1 SEE ALSO

  pkg_info(1), pkg_version(1), portupgrade(1), ports(7)

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

=head1 Author, Distribution and such

  parv, parv UNDERSCORE fm AT emailuser DOT net

  date: dec 23 2002

  version:  0.021

  This software is free to be used in any form only if proper credit is
  given.  I am not liable for any harm done; use it at your own risk.

=cut