#!/usr/bin/perl -w 
# -*-cperl-*-
## Filename: ucs-contrib
## Modified: Mon May  9 11:46:38 2005 (evert)   
##   Author: Stefan Evert
##  Purpose: execute UCS/Perl scripts from contrib/ tree
$| = 1;

use UCS;
use UCS::File;
use Getopt::Long;
use File::Find;

$Opt_Help = 0;					# --help, -h
$Opt_List = 0;					# --list, -l
$Opt_Category = undef;				# --category, --cat, -c
$Opt_Doc = 0;					# --doc, -d
$Opt_Verbose = 0;				# --verbose, -v

Getopt::Long::Configure("bundling_override", "noauto_abbrev", "nopermute");
$ok = GetOptions(
		 "help|h" => \$Opt_Help,
		 "list|l" => \$Opt_List,
		 "category|cat|c:s" => \$Opt_Category,
		 "doc|d" => \$Opt_Doc,
		 "verbose|v" => \$Opt_Verbose,
		);

$ok = 0
  if defined($Opt_Category) and $Opt_Category eq "" and not $Opt_List;
$ok = 0
  if $Opt_List and @ARGV > 0;
$ok = 0
  if (not $Opt_List) and @ARGV == 0;
$ok = 0
  if $Opt_Doc and $Opt_List;

die "Usage:  ucs-tool --list [--category | --category=<cat>]\n"
  . "        ucs-tool --doc <tool> [<ucsdoc flags>]\n"
  . "        ucs-tool <tool> ...\n"
  . "[type 'ucsdoc ucs-tool' for more information]\n"
  unless $ok and not $Opt_Help;

## set base of contrib/ tree and read category descriptions
$Base = "$UCS::PerlDir/contrib";
%Category = ();				# lookup hash with category descriptions
@Category = ();				# ordered list of all categories (as in CATEGORIES file)
$max_cat_width = 0;				# maximum width of category name
$fh = UCS::File::Open("$Base/CATEGORIES");
while(<$fh>) {
  chomp;
  @F = split /\t/;
  UCS::Die("Internal error: format error in file $Base/CATEGORIES, line #$.")
      unless @F == 2;
  ($name, $description) = @F;
  $Category{$name} = $description;
  push @Category, $name;
  $cat_width = length($name);
  $max_cat_width = $cat_width
    if $cat_width > $max_cat_width;
}
$fh->close;

## load all contributed tools from contrib/ tree (and assign to categories)
%ToolCat = ();					# map tool names to tool categories
%ToolFile = ();					# map tool names to filenames
%ToolLibdir = ();				# local module library for each tool 
find(sub {
       return 
	 unless s/(\.perl|\.pl)$//i and -s $File::Find::name > 0;
       my $tool = $`;				# (base) name of tool
       my $category = $File::Find::dir;
       UCS::Die("Internal error: can't find directory tree base ($Base) in directory name ($category)")
	   unless index($category, "$Base/") == 0;
       substr($category, 0, length($Base)+1) = "";
       UCS::Die("Internal error: unknown category ($category) for contributed script $_")
	   unless exists $Category{$category};
       UCS::Die("Internal error: multiple entries for contributed script '$tool'")
	   if exists $ToolCat{$tool};
       $ToolCat{$tool} = $category;
       $ToolFile{$tool} = $File::Find::name;
       $ToolLibdir{$tool} = "$File::Find::dir/lib";
     }, $Base);

## mode A: --list [--category]
if ($Opt_List) {
  if (not defined($Opt_Category)) {
    foreach $cat (@Category) {
      list_cat($cat);
    }
  }
  else {
    if ($Opt_Category eq "") {
      print_cat("Category", "Description");
      print_cat("--------", "-----------");
      foreach $cat (@Category) {
	print_cat($cat, $Category{$cat});
      }
    }
    else {
      @cats = expand_cat(match_cat($Opt_Category));
      foreach $cat (@cats) {
	list_cat($cat);
      }
    }
  }
}
## mode B: print embedded POD documentation (ucsdoc)
elsif ($Opt_Doc) {
  $tool = match_tool(shift @ARGV);
  exec("$UCS::PerlDir/bin/ucsdoc", @ARGV, $ToolFile{$tool});
}
## mode C: invoke specified tool
else {
  $tool = match_tool(shift @ARGV);
  exec $UCS::PerlBin, (map {"-I$_"} @UCS::PerlLibs, $ToolLibdir{$tool}), $ToolFile{$tool}, @ARGV;
}


## print category name + description (formatted and with indentation)
sub print_cat {
  my $name = shift;
  my $description = shift;
  my $depth = ($name =~ tr[/][]);
  $name = ("  " x $depth) . $name;    # indent by two blanks for each subcategory level
  my $col1width = $max_cat_width + 4; # allow for up to two levels of indentation
  printf "%-${col1width}s  %s\n", $name, $description;
}

## match category name case-insensitive (later perhaps also with unique abbreviations)
sub match_cat {
  my $name = shift;
  my ($cat) = grep { lc($_) eq lc($name) } @Category;
  die "Category '$name' not defined (try 'ucs-tool --list --category')\n"
    unless $cat;
  return $cat;
}

## expand category to include all subcategories
sub expand_cat {
  my $name = shift;
  my @expanded = $name;
  push @expanded, 
    grep {index($_, "$name/") == 0} @Category;
  return @expanded;
}

## list all tools found in given category
sub list_cat {
  my $name = shift;
  UCS::Die("Internal error: unknwon category '$name'")
    unless exists $Category{$name};
  my @tools = sort grep {$ToolCat{$_} eq $name} keys %ToolCat;
  print "\n";
  print_cat($name, "[".$Category{$name}."]");
  foreach my $tool (@tools) {
    print "     - $tool\n";
  }
}

## match tool name, with partial case-insensitive matching (only in $Opt_Category if specified)
sub match_tool {
  my $name = shift;
  my @tools = sort keys %ToolCat;
  if ($Opt_Category) {
    my %cats = map {$_ => 1} expand_cat(match_cat($Opt_Category));
    @tools = grep { exists $cats{ $ToolCat{$_} } } @tools;
  }
  my @matches = grep { index(lc($_), lc($name)) == 0 } @tools;
  if (@matches > 1) {				# multiple matches -> look for exact match
    @exact = grep { lc($_) eq lc($name) } @matches;
    if (@exact > 1) {
      @exact = grep { $_ eq $name } @exact;
    }
    die("Multiple matches found for tool '$name':\n",
	"\t".join(", ", @matches)."\n",
	"Please specify exact name or longer prefix.\n")
      unless @exact == 1;
    @matches = @exact;
  }
  die "No match found for tool '$name' (try 'ucs-tool --list')\n"
    unless @matches == 1;
  return shift @matches;
}


__END__

=head1 NAME

ucs-tool - Execute UCS/Perl scripts from contrib/ tree


=head1 SYNOPSIS

  ucs-tool --list [--category | --category=<cat>]
  ucs-tool --doc <tool> [<ucsdoc options>]
  ucs-tool [--category=<cat>] <tool> ...

=head1 DESCRIPTION

In addition to the UCS/Perl programs, which perform general tasks and will be
of interest to most users, the UCS distribution includes a number of UCS/Perl
scripts for more specific applications.  These scripts are not directly
accessible as command-line programs.  They are organised into a hierarchical
set of categories in the F<contrib/> directory tree, and can be invoked
through the B<ucs-tool> program.  If you want to add your own scripts to this
tree, read the section on L<WRITING CONTRIBUTED SCRIPTS|"WRITING CONTRIBUTED
SCRIPTS"> below.

=head2 LISTING CONTRIBUTED SCRIPTS

When the C<--list> (or C<-l>) option is specified, B<ucs-tool> lists all
available UCS/Perl scripts from the F<contrib/> tree, grouped by category.
Add the option C<--category> (or C<--cat> or C<-c>) for a listing of category
names and descriptions (without the individual tools).  You can also use the
special short form C<ucs-tool -lc> for this purpose.  When an argument is
given for C<--category>, only scripts from the specified category are listed
(the category name is case-insensitive).

Some scripts may provide manual pages in the form of embedded POD
documentation.  Such manual pages can be displayed with the C<--doc> (or
C<-d>) flag, followed by the name of the script.  See the section on L<SCRIPT
INVOCATION|"SCRIPT INVOCATION"> below for details on how script names are
matched.  B<ucs-tool> uses the B<ucsdoc> program to format manual pages and
accepts B<ucsdoc> options (such as C<-ps> and C<-tk>) I<after> the tool name.

=head2 SCRIPT INVOCATION

In order to invoke one of the contributed UCS/Perl scripts, simply specify its
name (as shown by the C<--list> option), followed by command-line arguments
for the selected script, e.g.

  ucs-tool dispersion-test -m 3 -N 100000 -k 100 -V 2500

All contributed scripts should include a short help page that can be displayed
with the C<--help> (or C<-h>) option.  Note that this is a script option and
therefore must be specified I<after> the script name:

  ucs-tool dispersion-test --help

Recall that full manual pages, when available, can be displayed with the
C<--doc> option specified I<before> the script name (as described above).

Script names are case-insensitive, and it is sufficient to specify a unique
prefix of the name.  For instance, you can invoke the B<print-documentation>
script with the short name C<ucs-tool print> or C<ucs-tool print-doc>.  It may
be easier to find a unique prefix when the search space is reduced to a
specific category with the C<--category> (or C<-c>) option.


=head1 WRITING CONTRIBUTED SCRIPTS

Contributed UCS/Perl scripts are collected in a directory tree rooted in
F<System/Perl/contrib/>.  Each subdirectory corresponds to a script category.
These categories are organised hierarchically according to the directory
structure (for instance, C<--list --category=Import> lists all scripts found
in the directory F<Import/> and its subdirectories, such as F<Import/NSP/> and
F<Import/CWB/>).  The file F<CATEGORIES> contains a listing of all known
categories with short descriptions (category names and descriptions must be
separated by a single TAB character). 

If you want to add your own UCS/Perl scripts to the repository, you should put
them in the F<Local/> directory (which is reserved for scripts that are not
part of the UCS distribution).  This is often the easiest way to make a
UCS/Perl script available to all users of a UCS installation.  Note that
script files I<must> have the extension C<.perl> or C<.pl>, which is not part
of the script name (e.g., the script B<nsp2ucs> in the category B<Import/NSP>
corresponds to the disk file F<Import/NSP/nsp2ucs.perl> in the F<contrib/>
tree).  You can also put your script in a different category or define your
own categories (which you must add to the F<CATEGORIES> file), but this will
interfere with upgrading to a new UCS release.  You are encouraged to share
scripts with other users.  To do so, please send them to the author (or
maintainer) of the UCS system, indicating which category they should be
included in.

Unlike ordinary UCS/Perl scripts, scripts placed in the F<contrib/> tree do
not have to be configured with B<ucs-config>.  They also do not have to be
executable and start with a shebang (C<#!>) line.  When invoked with the
B<ucs-tool> program, the necessary settings are made automatically.
Contributed scripts that require "private" modules (which are not installed in
a public directory) can place them in a subdirectory named F<lib/> (relative
to the location of the script file), or in further subdirectories as required
by the module's name.  The F<lib/> directory tree is automatically added to
Perl's search path.  Necessary data files should be wrapped in Perl modules
and stored in the F<lib/> subtree as well.  For instance, assume that a script
named B<my-script> in the B<Local> category (corresponding to the script file
F<Local/my-script.perl>) uses the private module B<My::Functions>.  This
module can automatically be loaded (with C<use My::Functions;>) from the file
F<Local/lib/My/Functions.pm> in the F<contrib/> directory tree.

All contributed UCS/Perl scripts should include a short help page describing
the script's function and command-line arguments, which is displayed when the
script is invoked with C<--help> or C<-h>.  Script authors are also encouraged
to write full manual pages as embedded POD documentation (which can then be
displayed with C<ucs-tool --doc>), but these are not mandatory.

=head1 COPYRIGHT

Copyright 2004-2005 Stefan Evert.

This software is provided AS IS and the author makes no warranty as to
its use and performance. You may use the software, redistribute and
modify it under the same terms as Perl itself.

=cut
