#!/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 maintena
+nce
##    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 len
+gths
                       , descr   => { long => '+DESC' , short => '+COM
+MENT' }
                    }
         };


##  preparation for printing list

#  create port regex; default is any port starting w/ any of digits an
+d
#  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] = 's
+hort' }
              , 'long|large|verbose'  => sub { $opt->{descr}->[0] = 'l
+ong'  }

              , '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 thir
+d
  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 local
+e,
  it's [a-zA-Z0-9].

  The given arguments/patterns separated by spaces/tabs are turned int
+o 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 thi
+s
    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 f
+or
                         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 p
+ort
    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 whic
+h
  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 databas
+e.
             It is overridden by -dbddir option.  Default is /var/db/p
+kg.

=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 l
+ine.

  /var/db/pkg/port/+CONTENTS
               File containing a port's dependency list, installed fil
+es,
               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 i
+s
  given.  I am not liable for any harm done; use it at your own risk.

=cut