# rda.pl: Setup, collect, render, and package diagnostic information
#
# $Id: rda.pl,v 1.104 2008/02/25 17:41:50 mschenke Exp $
# ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/bin/rda.pl,v 1.104 2008/02/25 17:41:50 mschenke Exp $
#
# Change History
# 20080210  MSC  Control the exit value for test modules

eval 'exec perl -w -S "$0" ${1+"$@"}'
  if 0; # not running under some shell

use strict;

BEGIN
{ use Cwd;
  use File::Basename;
  use File::Copy;
  use File::Spec;
  use Getopt::Std;
}

# Include packages in the compiled version

#perl2exe_exclude Digest::Perl::MD5

#perl2exe_include Digest::MD5
#perl2exe_include File::Spec::Mac
#perl2exe_include File::Spec::OS2
#perl2exe_include File::Spec::Unix
#perl2exe_include File::Spec::Win32
#perl2exe_include IO::File
#perl2exe_include IO::Handle
#perl2exe_include POSIX
#perl2exe_include Socket

#perl2exe_include RDA::Agent
#perl2exe_include RDA::Block
#perl2exe_include RDA::Daemon
#perl2exe_include RDA::Discover
#perl2exe_include RDA::Extra
#perl2exe_include RDA::Filter
#perl2exe_include RDA::Lock
#perl2exe_include RDA::Log
#perl2exe_include RDA::Module
#perl2exe_include RDA::Output
#perl2exe_include RDA::Pod
#perl2exe_include RDA::Profile
#perl2exe_include RDA::Remote
#perl2exe_include RDA::Render
#perl2exe_include RDA::Setting
#perl2exe_include RDA::Upgrade
#perl2exe_include RDA::Value
#perl2exe_include RDA::Web

#perl2exe_include RDA::Macro::Buffer
#perl2exe_include RDA::Macro::Data
#perl2exe_include RDA::Macro::DB
#perl2exe_include RDA::Macro::Env
#perl2exe_include RDA::Macro::Expr
#perl2exe_include RDA::Macro::File
#perl2exe_include RDA::Macro::Hcve
#perl2exe_include RDA::Macro::Html
#perl2exe_include RDA::Macro::Http
#perl2exe_include RDA::Macro::Invent
#perl2exe_include RDA::Macro::Remote
#perl2exe_include RDA::Macro::String
#perl2exe_include RDA::Macro::Temp
#perl2exe_include RDA::Macro::Value
#perl2exe_include RDA::Macro::Xml

#perl2exe_include RDA::Macro::Unix::Local
#perl2exe_include RDA::Macro::Unix::Remote

#perl2exe_include RDA::Macro::Windows::Local

#perl2exe_include RDA::Object::Buffer
#perl2exe_include RDA::Object::Data
#perl2exe_include RDA::Object::Html
#perl2exe_include RDA::Object::Parser
#perl2exe_include RDA::Object::Request
#perl2exe_include RDA::Object::Response
#perl2exe_include RDA::Object::Sgml
#perl2exe_include RDA::Object::UsrAgent
#perl2exe_include RDA::Object::Xml

# Change to the install directory
my ($cwd, $dir);
$cwd = exists($ENV{'RDA_CWD'}) ? $ENV{'RDA_CWD'} : get_cwd();
chdir($dir)
  if ($dir = dirname($0)) ne '.'
  || ($^X =~ m/\brda_\w+56$/ && ($dir = dirname($^X)) ne '.');

# Define global variables
my ($re_trc, $re_tst, @tb_all, %tb_abr, %tb_mod);
my %tb_trc = (
  't:' => 1,
  'T:' => 2,
  'T/' => 2,
  't/' => 2,
  );
my %tb_wrn = (
  OS  => "RDA-00017: Warning - ".
         "\%d command(s) not executed in \%s module(s)\n",
  SQL => "RDA-00015: Warning - ".
         "\%d database request(s) not executed in \%s module(s)\n",
  XML => "RDA-00018: Warning - ".
         "\%d XML request(s) not executed in \%s module(s)\n",
  );

# Check the operating system
my $vms     = ($^O eq 'VMS');
my $windows = ($^O eq 'MSWin32');

# Set the defaults
my $class;       # No default plugin class
my $collect = 0; # No data collection
my $debug = 0;   # No debug
my $direct = 0;  # Don't immediately render selected reports
my $exit = 0;    # Default exit value
my $force = 0;   # Only generate outdated reports
my $home;        # RDA install directory
my $init = 0;    # Macros not yet initialized
my $list;        # No temporary settings
my $mode = '*';  # Default action
my $new = 0;     # Reuse the current setup file
my $package = 0; # No report packaging
my $profile;     # Default setup profile
my $render = 0;  # No report rendering
my $save;        # Auto save controlled by the setup file
my $setup = 0;   # No setup
my $trace = 0;   # No trace
my $verbose = 0; # Silent mode
my $warn = 0;    # Don't display execution warnings
my @agent;       # Agent attributes

my $output = $windows ? 'NUL' : $vms ? 'nla0:' : '/dev/null';

# Transform some options
if ($vms || $windows)
{ $re_trc = qr#^([Tt][:\/])(.*)$#;
  $re_tst = qr#^([Mm][:\/])?([^:]+)([:\/](.*))?$#;
  foreach my $arg (@ARGV)
  { last if $arg eq '-';
    $arg = '-'.uc($arg) if $arg =~ s#^\/##;
  }
}
else
{ $re_trc = qr#^([Tt]:)(.*)$#;
  $re_tst = qr#^([Mm]:)?([^:]+)(:(.*))?$#;
}

# Parse the options
my %opts;
getopts("ABCDEFHIKLMOPQRSTVX:bcde:fhlm:no:p:s:tvwxy",\%opts);
$mode = 'A'                         if $opts{'A'};
$mode = 'B'                         if $opts{'B'};
$mode = $collect = '-'              if $opts{'C'};
$mode = 'D'                         if $opts{'D'};
$mode = 'E'                         if $opts{'E'};
$mode = 'F'                         if $opts{'F'};
$mode = 'H'                         if $opts{'H'};
$mode = 'I'                         if $opts{'I'};
$mode = 'K'                         if $opts{'K'};
$mode = 'L'                         if $opts{'L'};
$mode = 'M'                         if $opts{'M'};
$mode = 'O'                         if $opts{'O'};
$mode = $package = '-'              if $opts{'P'};
$mode = 'Q'                         if $opts{'Q'};
$mode = $render = '-'               if $opts{'R'};
$mode = $setup = '-'                if $opts{'S'};
$mode = 'T'                         if $opts{'T'};
$mode = 'V'                         if $opts{'V'};
($mode, $class) = ('X', $opts{'X'}) if $opts{'X'};
push(@agent, 'bkp', 0)              if $opts{'b'};
$debug = 1                          if $opts{'d'};
$list = $opts{'e'}                  if $opts{'e'};
$force = 1                          if $opts{'f'};
push(@agent, 'lck', 1)              if $opts{'l'} || $mode eq 'B';
push(@agent, 'dir', $opts{'m'})     if $opts{'m'};
$new = 1                            if $opts{'n'};
$output = $opts{'o'}                if $opts{'o'};
$profile = $opts{'p'}               if $opts{'p'};
$trace = 1                          if $opts{'t'};
$verbose = 1                        if $opts{'v'};
push(@agent, 'lck', -1)             if $opts{'w'};
$save = 0                           if $opts{'w'} || $mode eq 'T';
$mode = 'x'                         if $opts{'x'};
push(@agent, 'yes', 1)              if $opts{'y'} || $mode eq 'B';
($trace, $profile) = ($tb_trc{$1}, $2) if $profile && $profile =~ $re_trc;

do_check(@agent) if $opts{'c'};
if ($opts{'h'})
{ print <<"EOF";
Usage: rda.pl [-bcdflntvwxy] [-ABCDEHIKLMPQRSTV] [-e list] [-m dir]
              [-s name] [-o out] [-p prof] arg ...
        -A      Authentify user through the setup file
        -B      Start background collection
        -C      Collect diagnostic information
        -D      Delete specified modules from the setup
        -E      Explain specified error numbers
        -H      Halt background collection
        -I      Regenerate the index
        -K      Kill background collection
        -L      List the modules available
        -M      Display the related manual pages
        -O      Render output specifications from STDIN
        -P      Package the reports (tar or zip)
        -Q      Display the related setup questions
        -R      Generate specified reports
        -S      Setup specified modules
        -T      Execute test modules
        -V      Display component version numbers
        -b      Don't backup setup file before saving
        -c      Check the RDA installation and exit
        -d      Set debug mode
        -e list Specify a list of alternate setting definitions (var=val,...)
        -f      Set force mode
        -h      Display the command usage and exit
        -l      Use a lock file to prevent concurrent usage of a setup file
        -m dir  Specify the module directory ('modules' by default)
        -n      Start a new data collection
        -o out  Specify the file for background collection output redirection
        -p prof Specify the setup profile ('Default' by default)
        -s name Specify the setup name ('setup' by default)
        -t      Set trace mode
        -v      Set verbose mode
        -w      Wait as long as the background collection daemon is active
        -x      Produce module cross reference
        -y      Accept all defaults and skip all pauses
EOF
  exit(0);
}

# Determine the setup file name and location
{ my ($dir, $str);
  if ($str = $opts{'s'} || $ENV{'RDA_SETUP'})
  { $dir = dirname($str);
    push(@agent, 'ctl', mk_work(File::Spec->file_name_is_absolute($dir) ? $dir
      : File::Spec->catdir($cwd, $dir)));
    $str = basename($str);
    $str =~ s/\.cfg$//i;
    push(@agent, 'nam', $str);
  }
  else
  { push(@agent, 'ctl', mk_work($cwd));
  }
}

# Initialize the RDA agent
eval "require RDA::Agent";
die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;
my $h = RDA::Agent->new(@agent);
$h->load unless $new;

# Restrict STDERR usage
unless ($opts{'M'} || $opts{'Q'} || $opts{'x'})
{ my $cmd = exists($ENV{'RDA_WARN'}) ? $ENV{'RDA_WARN'} : '';
  my $rdr = ($cmd =~ m/^\&LOG$/i) ? '>&'.fileno($h->logfile || *STDOUT) :
            ($cmd =~ m/^[\w\/\\\.]/) ? '>>'.$cmd :
            $cmd ? undef :
            $windows ? '>NUL' :
            $vms ? '>nla0:' : '>/dev/null';
  if ($rdr)
  { open(STDERR, $rdr) || die "stderr error $!\n";;
    $SIG{'__DIE__'}  = sub { open(STDERR, ">&STDOUT") unless $^S };
    $SIG{'__WARN__'} = sub { print @_ };
  }
}

# Make temporary setup configuration
if (exists($ENV{'RDA_EDIT'}))
{ foreach my $arg (split(/,/, $ENV{'RDA_EDIT'}))
  { my ($key, $val) = split(/\=/, $arg, 2);
    next unless $key;
    $val = '' unless defined($val);
    $val =~ s/\\([0-7]{3}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
    $h->set_temp_setting($key, $val);
  }
}
if ($list)
{ foreach my $arg (split(/,/, $list))
  { my ($key, $val) = split(/\=/, $arg, 2);
    next unless $key;
    $val = '' unless defined($val);
    $val =~ s/\\([0-7]{3}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg;
    $h->set_temp_setting(uc($key), $val);
  }
}
$h->set_setting('RDA_ARGC', scalar(@ARGV),     'N', 'Number of arguments');
$h->set_setting('RDA_ARGV', join('|', @ARGV),  'T', 'Argument list');
$h->set_setting('RDA_HOME', $home = get_cwd(), 'D', 'RDA home directory');
if ($0 =~ m/\brda.pl$/ && $^X !~ m/\brda_\w+56$/)
{ my $cmd = $h->quote($^X);
  $h->set_setting('RDA_SELF', "$cmd rda.pl", 'T', 'Relaunch command');
  $h->set_setting('RDA_PERL', $cmd,          'F', 'Perl executable');
}
else
{ my $cmd = $^X;
  $cmd = File::Spec->catfile($home,basename($cmd))
    unless File::Spec->file_name_is_absolute($cmd);
  $h->set_setting('RDA_SELF', $h->quote($cmd), 'T', 'Relaunch command');
}
$h->set_setting('RDA_WORK', $h->get_info('ctl'), 'D', 'RDA work directory');

# Control STDOUT usage
if ($h->get_setting('RDA_RENDER'))
{ $direct = 1;
  $debug = $trace = $verbose = 0;
}

# Adjust the default requests
if ($mode eq '*')
{ $collect = $render = $package = 1;
  $setup = 1 unless $h->profile->chk_profile($profile);
  unless (scalar(@ARGV))
  { $setup = 1 unless $h->is_configured;
    $force = 1 if $h->get_setting('RPT_FORCE', 1);
  }
}

# Treat the requests
if ($setup)
{ my @tbl = $h->profile->set_profile($profile);
  @tbl = @ARGV if scalar(@ARGV);
  do_setup($h, $save, ($collect || $render || $package), @tbl);
  do_post($h, $save, 'POST_SETUP');
}
if ($collect)
{ do_collect($h, $save, @ARGV);
  do_post($h, $save, 'POST_COLLECT');
  $warn = !$direct;
}
if ($render)
{ do_render($h);
  do_post($h, $save, 'POST_RENDER');
  $warn = !$direct;
}
if ($package)
{ do_package($h, ($mode eq '*' && !scalar(@ARGV)));
  do_post($h, $save, 'POST_PACKAGE');
  $warn = !$direct;
}

# Treat the exclusive requests
if ($mode eq 'A')
{ do_authen($h, @ARGV);
}
elsif ($mode eq 'B')
{ do_bgnd($h, $output, @ARGV);
}
elsif ($mode eq 'D')
{ do_delete($h, @ARGV);
}
elsif ($mode eq 'E')
{ do_explain($h, @ARGV);
}
elsif ($mode eq 'F')
{ do_render($h, @ARGV);
}
elsif ($mode eq 'H')
{ do_halt($h);
}
elsif ($mode eq 'I')
{ do_index($h);
}
elsif ($mode eq 'K')
{ do_kill($h);
}
elsif ($mode eq 'L')
{ do_list($h);
}
elsif ($mode eq 'M')
{ do_man($h, @ARGV);
}
elsif ($mode eq 'O')
{ do_output($h);
}
elsif ($mode eq 'Q')
{ my @tbl = $h->profile->set_profile($profile);
  @tbl = @ARGV if scalar(@ARGV);
  do_question($h, @tbl);
}
elsif ($mode eq 'T')
{ $h->profile->set_profile($profile) if $profile;
  $exit = do_test($h, @ARGV);
}
elsif ($mode eq 'V')
{ do_version($h);
}
elsif ($mode eq 'X')
{ do_extern($h, $class, @ARGV);
}
elsif ($mode eq 'x')
{ do_xref($h, @ARGV);
}
elsif ($mode eq '?')
{ $h->dsp_text($windows ? 'Start/Windows' : 'Start',
    $windows && !exists($ENV{'RDA_NO_PAUSE'}));
}

# Save the setup
if (!defined($save) && index('?EFHIKLMOQTVx', $mode) < 0)
{ print "\tUpdating the setup file ...\n" if $verbose;
  $h->save;
}

# Report execution warnings
if ($warn)
{ my ($cnt, @mod);

  foreach my $key (qw(SQL OS XML))
  { if ($cnt = $h->get_setting($key.'_WARNINGS'))
    { ($cnt, @mod) = split(/\|/, $cnt);
      @mod = map {exists($tb_abr{$_}) ? $tb_abr{$_} : $_} @mod;
      printf($tb_wrn{$key}, $cnt, join(', ', @mod));
    }
  }
}

# Close the agent and exit
$h->end;

exit($exit);

# Store user authentication in the setup file
sub do_authen
{ my $slf = shift;

  die "RDA-00016: S0999END setup required for managing authentication\n"
    unless $slf->is_configured('S999END');
  $slf->set_current('S999END');
  foreach my $arg (@ARGV)
  { my ($key, $pwd, $usr);

    ($usr, $pwd) = split(/\//, $arg);
    next unless $usr;
    if ($usr =~ m/^(\*)?(\w+)(\@([\+\w]+))?$/)
    { $usr = uc($usr);
      $key = uc($3 ? "_$4__$2" : $2);
      $key =~ s/\+/plus/g;
      if ($1)
      { print "Deleting '$usr' authentication ...\n" if $verbose;
        $slf->del_setting("SQL_PASSWORD_$key");
      }
      else
      { print "Adding '$usr' authentication ...\n" if $verbose;
        $pwd = $slf->ask_password("Enter password for '$usr': ") unless $pwd;
        $pwd = pack('u', $pwd);
        chomp($pwd);
        $slf->set_setting("SQL_PASSWORD_$key", $pwd, 'T',
          "Password for '$usr'");
      }
    }
    elsif ($usr =~ m/^(\*)?(\w+)\@([\w\.\-]+)(:\d+:[\+\w]+)$/)
    { ($usr, $key) = _get_authen($slf, $2, $3, $4);
      if ($1)
      { print "Deleting '$usr' authentication ...\n" if $verbose;
        $slf->del_setting("SQL_USER_$key");
        $slf->del_setting("SQL_PASS_$key");
      }
      else
      { print "Adding '$usr' authentication ...\n" if $verbose;
        $pwd = $slf->ask_password("Enter password for '$usr': ") unless $pwd;
        $pwd = pack('u', $pwd);
        chomp($pwd);
        $slf->set_setting("SQL_USER_$key", $usr, 'T', "User/SID information");
        $slf->set_setting("SQL_PASS_$key", $pwd, 'T', "Password for '$usr'");
      }
    }
  }
}

sub _get_authen
{ my ($slf, $usr, $hst, $sid) = @_;
  my ($num, $ref, $val);

  # Normalize the user string
  $usr = uc($usr).'@'.$hst.uc($sid);

  # Search if it already exists
  foreach my $key ($slf->grep_setting('^SQL_USER_\d+$'))
  { return ($usr, substr($key, 9)) if $usr eq $slf->get_setting($key);
  }

  # Determine its identifier
  $num = unpack("%32C*", $usr);
  do
  { $ref = sprintf('%06d', $num++);
  } while defined($slf->get_setting("SQL_USER_$ref"));
  ($usr, $ref);
}

# Start a background collection
sub do_bgnd
{ my $slf = shift;
  my $out = shift;
  my ($dmn, $mod, $ret, @tbl);

  print "\tStarting a background collection ...\n" if $verbose;

  # Identify the sampling modules
  if (scalar(@_))
  { get_mod_lists($slf);
    foreach my $nam (@_)
    { $mod = ($nam =~ $re_trc) ? $2 : $nam;
      $mod = uc($mod) if $vms;
      $mod = $tb_mod{$mod} if exists($tb_mod{$mod});
      push(@tbl, $mod);
    }
    @tbl = sort @tbl;
  }
  else
  { @tbl = split(/,/, $slf->get_setting('SMPL_MODULES', ''));
  }

  # Start the background collection
  $dmn = $slf->daemon;
  $ret = $dmn->run_bgnd($out, @tbl);
  if ($ret > 0)
  { $verbose = 0;
  }
  elsif ($ret == 0)
  { # Don't save the setup in the launcher
    $mode = '?';

    # When forced, try to halt it
    if ($force)
    { print "\tHalting the background collection ...\n" if $verbose;
      sleep(1);
      $dmn->halt_bgnd;
    }
  }
}

# Check the RDA installation
sub do_check
{ if (scalar(@ARGV))
  { # Check the module syntax
    my ($cnt, $dir, $err, $mod, %agt);

    eval "require RDA::Block";
    die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;
    eval "require RDA::Module";
    die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;
    eval "require RDA::Profile";
    die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;

    %agt = @_;
    $cnt = 0;
    $agt{'dir'} = 'modules' unless exists($agt{'dir'});
    foreach my $arg (@ARGV)
    { print "Checking $arg ...\n" if $verbose;
      $dir = dirname($arg);
      $dir = $agt{'dir'} if $dir eq '.';
      $mod = basename($arg);
      if ($mod =~ m/^profiles?$/i)
      { eval {RDA::Profile->new($dir)->load;};
        $err = $@;
      }
      elsif ($mod =~ m/^rda\.cfg$/i)
      { eval {RDA::Profile->new($dir)->load($mod);};
        $err = $@;
      }
      elsif ($mod =~ s/\.cfg$//i)
      { eval {RDA::Module->new($mod, $dir)->load;};
        $err = $@;
      }
      elsif ($mod =~ s/\.(ctl|def)$//i)
      { $err = RDA::Block->new($mod, $dir)->load;
      }
      else
      { next;
      }
      print $mod.($err ? " has syntax errors.\n" : " syntax OK\n") if $verbose;
      ++$cnt if $err;
    }
    exit(1) if $cnt;
  }
  else
  { # Check the RDA installation
    my ($cnt, $fil, $nam, $pth, $ptr, $sep, $sta, $tot, %tb_abr, %tb_cat);

    # Get the file list
    print "Loading the file list ...\n" if $verbose;
    unless (open(LST, '<'.
      File::Spec->catfile($opts{'m'} || 'modules', 'rda.dat')))
    { die "RDA-00011: Missing file list\n" unless open(LST, '<rda.dat');
      close(LST);
      die "RDA-00012: Directory structure not preserved\n";
    }

    # Load the file list
    $cnt = $tot = 0;
    while (<LST>)
    { s/[\n\r\s]+$//;
      my ($typ, $dir, $sum, $nam) = split(/\s+/, $_, 4);
      next unless $typ && $dir && $nam && $typ ne '#';
      $tot += $sum;
      unless ($typ eq '-')
      { $tb_cat{$dir}->{$nam} = [$sum, lc($typ) eq 'f', $typ eq lc($typ)];
        $tb_cat{$dir}->{lc($nam)} = $tb_cat{$dir}->{$nam} if $vms;
      }
    }
    close(LST);
    die "RDA-00013: File list corrupted\n" if $tot % 65535;

    # Check the RDA files
    foreach my $dir (sort keys(%tb_cat))
    { $pth = ($dir eq '.')
        ? File::Spec->curdir
        : File::Spec->catdir(split(/\//, $dir));
      print "Checking the directory '$dir' ...\n" if $verbose;

      # Check the directory content
      if (opendir(DIR, $pth))
      { foreach $nam (sort readdir(DIR))
        { next unless -f ($fil = File::Spec->catfile($pth, $nam));
          push(@{$tb_abr{$1}}, $nam)
            if $nam =~ m/^S\d{3}([A-Za-z]\w*)\.(ctl|def)$/i;
          $nam =~ s/\.ctl$/.def/;
          next unless exists($tb_cat{$dir}->{$nam});
          $ptr = $tb_cat{$dir}->{$nam};
          $sta = '';
          $sep = "File '$fil':";
          if (-r $fil)
          { unless ($ptr->[0] == _get_cksum($fil))
            { $sta .= "$sep altered";
              $sep = ',';
            }
            unless ($ptr->[1] || $windows || -x $fil)
            { $sta .= "$sep not executable";
              $sep = ',';
            }
          }
          else
          { $sta = "$sep not readable";
          }
          $ptr->[2] = 1;
          if ($sta)
          { print "\t$sta\n";
            ++$cnt;
          }
        }
        closedir(DIR);

        # Identify missing files
        foreach $nam (sort keys(%{$tb_cat{$dir}}))
        { unless ($tb_cat{$dir}->{$nam}->[2])
          { print "\tFile '".File::Spec->catfile($dir, $nam)."': missing\n";
            ++$cnt;
          }
        }
      }
      else
      { # Check if that directory contains any mandatory file
        foreach $nam (sort keys(%{$tb_cat{$dir}}))
        { unless ($tb_cat{$dir}->{$nam}->[2])
          { print "\tDirectory '$dir': not accessible\n";
            ++$cnt;
          }
        }
        next;
      }

      # Check the abbreviation unicity
      foreach my $abr (sort keys(%tb_abr))
      { next unless scalar(@{$tb_abr{$abr}}) > 1;
        print "\tAbbrevation '$abr' not unique (used in ",
          join(', ', @{$tb_abr{$abr}}), ")\n";
        ++$cnt;
      }
    }
    die "RDA-00014: $cnt issue(s) found in the RDA installation\n" if $cnt;
    print "No issues found\n" if $verbose;
  }
  exit (0);
}

sub _get_cksum
{ my ($fil) = @_;
  my $sum = 0;

  if (open(FIL, "<$fil"))
  { binmode(FIL);
    while(<FIL>)
    { s/\$(Header|Id|Revision):\s.*?\$/\$$1\$/;
      $sum += unpack("%32C*", $_);
    }
    close(FIL);
  }
  $sum %= 65535;
}

# Generate the reports
sub do_collect
{ my $slf = shift;
  my $flg = shift;
  my ($cnt, $opt, $str, %tbl);

  print "\tCollecting diagnostic data ...\n" if $verbose;

  # Determine the module list
  $cnt = 0;
  get_mod_lists($slf);
  if (scalar(@_))
  { # Identify the modules
    foreach my $nam (@_)
    { ($opt, $str) = ($trace, $nam);
      ($opt, $str) = ($tb_trc{$1}, $2) if $nam =~ $re_trc;
      foreach my $mod (split(/\-/, $str))
      { $mod = uc($mod) if $vms;
        $mod = $tb_mod{$mod} if exists($tb_mod{$mod});
        $mod =~ s/\.(cfg|ctl|def)$//i;
        $tbl{$mod} = $opt;
      }
    }

    # Setup the modules that still require configuration
    foreach my $nam (sort keys(%tbl))
    { $slf->setup($nam, $trace, $flg)
        unless $slf->is_disabled($nam) || $slf->is_configured($nam);
    }

    # Prepare the execution list
    foreach my $nam (keys(%tbl))
    { if ($slf->is_disabled($nam))
      { $slf->del_reports($nam);
        delete($tbl{$nam});
      }
      else
      { ++$cnt;
      }
    }
    foreach my $nam (split(/,/, $slf->get_setting('RDA_COLLECT', '')))
    { $tbl{$nam} = $trace unless exists($tbl{$nam});
    }
  }
  else
  { # Prepare the execution list
    %tbl = map {$_ => $trace}
      split(/,/, $slf->get_setting('RDA_COLLECT', ''));
    foreach my $nam (@tb_all)
    { next unless $slf->is_configured($nam);
      if ($slf->is_disabled($nam))
      { $slf->del_reports($nam);
      }
      elsif (!$slf->is_collected($nam) || ($slf->is_done($nam) && $force))
      { $tbl{$nam} = $trace;
        ++$cnt;
      }
    }
  }

  # Collect diagnostic information
  if ($cnt || !defined($slf->get_setting('RPT_LAST')))
  { $slf->init($trace, 1) unless $init++;
    foreach my $nam (keys(%tbl))
    { foreach my $key (split(/,/, $slf->get_setting("${nam}_TEMP", '')))
      { $slf->set_temp_setting($key, '') if $key;
      }
    }
    foreach my $nam (sort keys(%tbl))
    { exit(1) if $slf->collect($nam, $debug, $tbl{$nam}, $flg);
    }
  }
  print "\t\tNo module requiring data collection\n" if $verbose && !$cnt;
}

# Delete modules
sub do_delete
{ my $slf = shift;

  print "\tDeleting module settings ...\n" if $verbose;

  # Get the modules that are always collected
  my %tbl = map {$_ => 1} split(/,/, $slf->get_setting('RDA_COLLECT'));

  # Delete the modules
  get_mod_lists($slf);
  foreach my $arg (@_)
  { foreach my $mod (split(/\-/, $arg))
    { $mod = uc($mod) if $vms;
      $mod = $tb_mod{$mod} if exists($tb_mod{$mod});
      $mod =~ s/\.(cfg|ctl|def)$//i;
      print "\t\t- $mod ...\n" if $verbose;

      # Do not delete modules that must be executed at each run
      if (exists($tbl{$mod}))
      { print "RDA-00021: Cannot delete $mod\n";
        next;
      }

      # Delete the reports when forced
      $slf->del_reports($mod) if $force && $slf->is_collected($mod);

      # Delete the module
      if ($slf->is_configured($mod))
      { if ($slf->is_done($mod))
        { print "RDA-00022: Option '-f' required to delete ".$mod
            ." and its collected data\n";
        }
        else
        { $slf->del_module($mod);
        }
      }
    }
  }
}

# Explain error messages
sub do_explain
{ my $slf = shift;
  my ($sep, @buf);

  print "\tExplaining errors ...\n" if $verbose;
  $sep = '';
  foreach my $err (@ARGV)
  { die "RDA-00007: Error $err not found\n"
      unless scalar(@buf = $slf->explain($err));
    print $sep, join("\n", @buf), "\n";
    $sep = "\n";
  }
}

# Execute an external call
sub do_extern
{ my $slf = shift;
  my $cls = shift;
  my $cmd = shift;
  my $ret = 0;

  # Transfer debug, force, trace, and verbose flags
  $slf->set_temp_setting('RDA_DEBUG',1) if $debug;
  $slf->set_temp_setting('RDA_FORCE',1) if $force;
  $slf->set_temp_setting('RDA_TRACE',1) if $trace;
  $slf->set_temp_setting('RDA_VERBOSE',1) if $verbose;

  # Perform the external call
  if ($cmd)
  { $cls =~ s/^(rda::[a-z])/\U$1/;
    eval "require RDA::$cls";
    if ($@)
    { eval "require $cls";
    }
    else
    { $cls = "RDA::$cls";
    }
    die "RDA-00008: External package '$cls' not available:\n$@" if $@;
    $ret = eval "$cls\:\:$cmd(\$h, \@_)";
    die "RDA-00009: Error in external call:\n$@" if $@;
  }

  # Don't save the setup unless requested
  $mode = '?' unless $ret;
}

# Halting a background collection
sub do_halt
{ my $slf = shift;

  print "\tHalting the background collection ...\n" if $verbose;
  $slf->daemon->halt_bgnd;
}

# Regenerate the index
sub do_index
{ print "\tGenerating the index ...\n" if $verbose;
  shift->render->gen_index($force);
}

# Kill a background collection
sub do_kill
{ my $slf = shift;

  print "\tKilling the background collection ...\n" if $verbose;
  $slf->daemon->kill_bgnd;
}

# List the available modules
sub do_list
{ my $slf = shift;

  if (scalar(@ARGV))
  { my $sep = '';
    foreach my $typ (@ARGV)
    { if ($typ =~ m/^(c|q|s)$/i)
      { _list_modules($slf, 0, $sep);
      }
      elsif ($typ =~ m/^(l|levels?)$/i)
      { _list_levels($slf, $sep);
      }
      elsif ($typ =~ m/^(m|modules?)$/i)
      { _list_modules($slf, 1, $sep);
      }
      elsif ($typ =~ m/^(p|profiles?)$/i)
      { _list_profiles($slf, $sep);
      }
      elsif ($typ =~ m/^t$/i)
      { _list_tools($slf, 1, $sep);
        _list_tools($slf, 0, "\n");
      }
      elsif ($typ =~ m/^tests?$/i)
      { _list_tools($slf, 0, $sep);
      }
      elsif ($typ =~ m/^tools?$/i)
      { _list_tools($slf, 1, $sep);
      }
      else
      { die "RDA-00023: Invalid list type '$typ'\n";
      }
      $sep = "\n";
    }
  }
  else
  { _list_modules($slf, 1, '');
    _list_tools($slf, 1, "\n");
    _list_tools($slf, 0, "\n");
    _list_levels($slf, "\n");
    _list_profiles($slf, "\n");
  }
}

sub _list_levels
{ my ($slf, $sep) = @_;

  print "${sep}Defined setting levels are:\n";
  foreach my $nam (sort $slf->profile->get_levels)
  { print "  $nam\n";
  }
}

sub _list_modules
{ my ($slf, $srt, $sep) = @_;
  my ($flg, $mrk, @tbl, %tbl);

  print "${sep}Available data collection modules are:\n";
  %tbl = map {$_ => 1} split(/,/, $slf->get_setting('RDA_COLLECT', ''))
    unless $force;
  get_mod_lists($slf, 1);
  @tbl = $srt ? sort {$tb_abr{$a} cmp $tb_abr{$b}} @tb_all : @tb_all;
  foreach my $nam (@tbl)
  { next if exists($tbl{$nam});
    if ($slf->is_configured($nam))
    { $mrk = $flg = '*';
    }
    else
    { $mrk = ' ';
    }
    printf(" %s%-8s %s\n", $mrk, $tb_abr{$nam}, $slf->get_title($nam, ''));
  }
  print "A '*' before a module name indicates that its setup has been done.\n"
    if $flg;
}

sub _list_profiles
{ my ($slf, $sep) = @_;
  my ($dft, $flg, $max, $mrk, $prf, $val, %dft, %tbl);

  # Get the profile list
  $prf = $slf->profile;
  $max = 0;
  foreach my $nam ($prf->get_profiles)
  { next unless ($val = $prf->get_title($nam));
    $tbl{$nam} = $val;
    $max = $val if ($val = length($nam)) > $max;
  }

  # Display the profile list
  if($max++)
  { print "${sep}Available profiles are:\n";
    %dft = map {$_ => 1} $prf->get_profile;
    foreach my $nam (sort keys(%tbl))
    { if (exists($dft{$nam}))
      { $mrk = $flg = '*';
      }
      else
      { $mrk = ' ';
      }
      printf(" %s%-*s %s\n",$mrk, $max, $nam, $tbl{$nam});
    }
    print "A '*' before a profile name indicates the current profile.\n"
      if $flg;
  }
}

sub _list_tools
{ my ($slf, $typ, $sep) = @_;
  my ($fil, $flg, $mrk, %dft, %tbl);

  get_tst_lists($slf, 1);
  %dft = map {$_ => 1} split(/,/, $slf->get_setting('RDA_TEST', ''));

  # Read the tool list
  $fil = File::Spec->catfile($slf->get_setting('MOD_DIRECTORY'), 'tools.txt');
  if (open(IN, "<$fil"))
  { while (<IN>)
    { s/[\n\r\s]+$//;
      $tbl{$_} = 0 if m/^(TL|TST)\w+$/i;
    }
    close(IN);
  }

  # Display the tool or test module list
  print "${sep}Available ".($typ ? "tools" : "test modules")." are:\n";
  foreach my $nam (@tb_all)
  { next if $typ xor exists($tbl{$nam});
    if (exists($dft{$nam}))
    { $mrk = $flg = '*';
    }
    else
    { $mrk = ' ';
    }
    printf(" %s%-8s %s\n", $mrk, $tb_abr{$nam}, $slf->get_title($nam, ''));
  }
  print "A '*' before a module name indicates a default module.\n" if $flg;
}

# Display the manual pages
sub do_man
{ my $slf = shift;
  my %tb_tst;

  print "\tDisplaying manual pages ...\n" if $verbose;
  get_tst_lists($slf,1);
  %tb_tst = %tb_mod;
  get_mod_lists($slf,1);
  my $out = $slf->pod;
  if (scalar(@_))
  { foreach my $mod (@_)
    { $mod =  uc($mod) if $vms;
      if (exists($tb_mod{$mod}))
      { $mod =  $tb_mod{$mod}
      }
      elsif (exists($tb_tst{$mod}))
      { $mod =  $tb_tst{$mod}
      }
      $mod =~ s/(\.(cfg|ctl|def))?$//i;
      $out->display($mod);
    }
  }
  else
  { $out->display('rda');
  }
}

# Render output specifications
sub do_output
{ shift->render->gen_output;
}

# Package the reports
sub do_package
{ my ($slf, $msg) = @_;
  my ($cas, $cmd, $dir, $flt, $grp, $log, $nod, $rpt, $sep, $suf, $tgt);

  print "\tPackaging the reports ...\n" if $verbose;
  $flt = $slf->output->is_filtered;
  $slf->log_suspend;

  # Move to the reporting directory
  chdir($dir = $slf->get_setting('RPT_DIRECTORY')) ||
    die "RDA-00001: Cannot change to the output directory\n";

  # Archive the reports
  $cas = $slf->get_setting('RDA_CASE');
  $grp = $slf->get_setting('RPT_GROUP');
  $nod = $flt ? 'rda' : $slf->get_setting('MACHINE_NAME');
  $nod =~ s/[\W_]+/_/g;
  ($sep, $tgt) = $slf->is_vms
    ? ('"', "RDA\$$grp\_$nod")
    : ('',  "RDA.$grp\_$nod");
  $tgt .= '_'.$slf->get_setting('RPT_LAST')
    if $slf->get_setting('RPT_KEEP', 0);
  $tgt = lc($tgt) unless $cas;
  if (($cmd = $slf->get_setting('CMD_ZIP')) && !exists($ENV{'RDA_NO_ZIP'}))
  { $tgt .= ($suf = '.zip');
    1 while unlink($tgt);
    _package("$cmd -9 -q $sep-D$sep $tgt -\@", $grp,
      "RDA-00002: Cannot zip the reports\n");
  }
  elsif (($cmd = $slf->get_setting('CMD_PAX')) && !exists($ENV{'RDA_NO_PAX'}))
  { 1 while unlink("$tgt.tar", "$tgt.tar.Z", "$tgt.tar.gz");
    _package("$cmd -w -f $tgt.tar", $grp,
      "RDA-00003: Cannot package the reports using pax\n");
    $tgt .= ($suf = _compress($slf, $tgt, '.tar'));
  }
  elsif (($cmd = $slf->get_setting('CMD_TAR')) && !exists($ENV{'RDA_NO_TAR'}))
  { $log = (-r 'RDA.log') ? 'RDA.log' : (-r 'rda.log') ? 'rda.log' : '';
    foreach my $sub (qw(archive extern remote sample))
    { $log .= ' '.File::Spec->catfile($sub, "$grp\_*")
        if _check_dir($sub, $grp);
    }
    1 while unlink("$tgt.tar", "$tgt.tar.Z", "$tgt.tar.gz");
    system("$cmd -cf $tgt.tar $log $grp\_*");
    die "RDA-00004: Cannot package the reports using tar\n" if $?;
    $tgt .= ($suf = _compress($slf, $tgt, '.tar'));
  }
  elsif (($cmd = $slf->get_setting('CMD_JAR')) && !exists($ENV{'RDA_NO_JAR'}))
  { $tgt .= ($suf = '.zip');
    $log = (-r 'RDA.log') ? 'RDA.log' : (-r 'rda.log') ? 'rda.log' : '';
    foreach my $sub (qw(archive extern remote sample))
    { $log .= ' '.File::Spec->catfile($sub, "$grp\_*")
        if _check_dir($sub, $grp);
    }
    1 while unlink($tgt);
    system("$cmd $sep-cfM$sep $tgt $log $grp\_*");
    die "RDA-00019: Cannot package the reports using jar\n" if $?;
  }
  else
  { die "RDA-00006: Archive command not -yet- identified\n";
  }

  # Move the report package to the transfer directory
  if ($rpt = $slf->get_setting('RPT_TRANSFER'))
  { # Move the report package to the transfer directory
    die "RDA-00020: Cannot create the transfer directory:\n $!\n"
        unless -d 'transfer' || mkdir('transfer', 0770);
    $rpt .= $suf;
    move($tgt, File::Spec->catfile('transfer', $rpt));
  }

  # Return to the RDA install directory
  chdir($home) ||
    die "RDA-00000: Cannot change to the RDA install directory\n";

  # Display the thanks message
  $slf->log_resume;
  $slf->log('P', $tgt);
  if ($rpt)
  { print "\t\t$rpt created for transfer\n" if $verbose;
  }
  elsif ($msg)
  { # Display the report message
    $log = "$grp\__start.htm";
    $log = lc($log) unless $cas;
    if ($windows)
    { $slf->dsp_text('Packaging/Windows', 0, beg => $log, tgt => $tgt);
    }
    elsif ($^O eq 'cygwin')
    { $slf->dsp_text('Packaging/Cygwin', 0, beg => $log, tgt => $tgt);
    }
    elsif ($vms)
    { $slf->dsp_text('Packaging/VMS', 0, beg => $log,
        tgt => File::Spec->catfile($slf->get_setting('RPT_DIRECTORY'), $tgt));
    }
    else
    { my ($ftp, $hom);

      $ftp = get_cwd();
      $ftp =~ s#^(/export)?$hom## if $hom = $ENV{'HOME'};
      $slf->dsp_text('Packaging', 0, beg => $log, tgt => $tgt, ftp => $ftp);
    }
  }
  elsif ($verbose)
  { print "\t\t$tgt created\n";
  }
}

sub _check_dir
{ my ($dir, $grp) = @_;

  $grp = qr/^$grp\_/i;
  if (opendir(DIR, $dir))
  { foreach my $nam (readdir(DIR))
    { return 1 if $nam =~ $grp;
    }
    closedir(DIR);
  }
  0;
}

sub _package
{ my ($cmd, $grp, $err) = @_;
  my $alt;

  $alt = qr/^$grp\_0.*\.fil$/i;
  $grp = qr/^$grp\_/i;

  # Get first the alias files and the log file
  opendir(DIR, File::Spec->curdir)
    || die "RDA-00005: Cannot list the reports\n";
  open(CMD, "| $cmd") || die $err;
  foreach my $nam (readdir(DIR))
  { print CMD $nam, "\n" if $nam =~ $alt || $nam =~ m/^RDA.log$/i;
  }
  closedir(DIR);

  # Get the report files
  opendir(DIR, File::Spec->curdir)
    || die "RDA-00005: Cannot list the reports\n";
  foreach my $nam (readdir(DIR))
  { next if $nam =~ $alt;
    print CMD $nam, "\n" if $nam =~ $grp;
  }
  closedir(DIR);

  # Get the files from the subdirectories
  foreach my $sub (qw(archive extern remote sample))
  { if (opendir(DIR, $sub))
    { foreach my $nam (readdir(DIR))
      { print CMD File::Spec->catfile($sub, $nam), "\n" if $nam =~ $grp;
      }
      closedir(DIR);
    }
  }
  close(CMD) || die $err;
}

sub _compress
{ my ($slf, $tgt, $suf) = @_;
  my $cmd;

  if (($cmd = $slf->get_setting('CMD_GZIP')) &&
    !exists($ENV{'RDA_NO_GZIP'}))
  { system("$cmd -9 -q $tgt$suf");
    $suf .= '.gz';
  }
  elsif (($cmd = $slf->get_setting('CMD_COMPRESS')) &&
    !exists($ENV{'RDA_NO_COMPRESS'}))
  { system("$cmd $tgt$suf");
    $suf .= '.Z';
  }
  $suf;
}

# Execute a post treatment
sub do_post
{ my ($slf, $flg, $typ) = @_;
  my ($ini, $mod);

  foreach my $nam ($slf->grep_setting("^$typ","n"))
  { if ($mod = $slf->get_setting($nam))
    { unless($ini)
      { print "\tExecuting the post treatment ($typ) ...\n" if $verbose;
        $slf->init($trace, 1) unless $init;
        $ini = $init = 1;
      }
      exit(1) if $slf->collect($mod, $debug, $trace, $flg);
    }
  }
}

# Display the setup questions
sub do_question
{ my $slf = shift;
  my %tb_tst;

  print "\tDisplaying setup questions ...\n" if $verbose;
  get_tst_lists($slf,1);
  %tb_tst = %tb_mod;
  get_mod_lists($slf,1);
  if (scalar(@_))
  { foreach my $arg (@_)
    { foreach my $mod (split(/\-/, $arg))
      { $mod =  uc($mod) if $vms;
        if (exists($tb_mod{$mod}))
        { $mod =  $tb_mod{$mod}
        }
        elsif (exists($tb_tst{$mod}))
        { $mod =  $tb_tst{$mod}
        }
        $mod =~ s/(\.(cfg|ctl|def))?$//i;
        $slf->dsp_module($mod);
      }
    }
  }
}

# Generate the reports
sub do_render
{ my $slf = shift;
  my $cnt = 0;

  print "\tGenerating the reports ...\n" if $verbose;
  my $out = $slf->render;
  if (scalar(@_))
  { # Treat all arguments
    foreach my $arg (@_)
    { my ($nam, $ttl) = split(/\:/, $arg, 2);
      print "\t\t- $nam ...\n" if $verbose;
      $out->gen_html($nam,$ttl);
      ++$cnt;
    }
  }
  else
  { # Treat existing reports
    foreach my $fil ($out->get_reports($force))
    { print "\t\t- $fil ...\n" if $verbose;
      $out->gen_html($fil);
      ++$cnt;
    }
    print "\t\tNo pending report\n" if $verbose && !$cnt;
  }

  # Generate the common files and the index page
  if ($cnt || -d File::Spec->catdir($slf->get_setting('RPT_DIRECTORY'), 'ref'))
  { print "\t\t- Report index ...\n" if $verbose;
    $out->gen_index;
  }
}

# Execute the setup phase
sub do_setup
{ my $slf = shift;
  my $flg = shift;
  my $nxt = shift;
  my ($cnt, $str, @mod);

  print "\tSetting up ...\n" if $verbose;
  get_mod_lists($slf);
  if (scalar(@_))
  { # Identify the modules from arguments
    foreach my $nam (@_)
    { $str = ($nam =~ m/^([Tt]:)?(.*)$/) ? $2 : $nam;
      foreach my $mod (split(/\-/, $str))
      { $mod = uc($mod) if $vms;
        $mod = $tb_mod{$mod} if exists($tb_mod{$mod});
        $mod =~ s/\.(cfg|ctl|def)$//i;
        push(@mod, $mod);
      }
    }

    # Setup requested modules
    foreach my $nam (sort @mod)
    { $slf->setup($nam, $trace, $flg) unless $slf->is_reconfigured($nam);
    }
  }
  else
  { # Setup available modules
    $cnt = 0;
    foreach my $nam (@tb_all)
    { next if $slf->is_reconfigured($nam)
        || ($slf->is_configured($nam) && !$force);
      $slf->setup($nam, $trace, $flg);
      ++$cnt;
    }
    print "\t\tNo unconfigured module\n" if $verbose && !$cnt;
    $slf->dsp_text($windows ? 'Setup/Windows' : $vms ? 'Setup/VMS' : 'Setup')
      unless $nxt;
  }
}

# Test the database access
sub do_test
{ my $slf = shift;
  my ($arg, $cnt, $man, $mod, $opt, %tbl);

  print "\tTesting ...\n" if $verbose;
  get_tst_lists($slf, 1);

  # Determine the module list
  $cnt = 0;
  if (scalar(@_))
  { # Prepare the execution list
    foreach my $nam (@_)
    { $opt = $trace;
      ($opt, $nam) = ($tb_trc{$1}, $2) if $nam =~ $re_trc;
      if ($nam =~ $re_tst)
      { $man = $1 || '';
        $nam = $vms ? uc($2) : $2;
        $arg = $3 || '';
        $nam = $tb_mod{$nam} if exists($tb_mod{$nam});
        $nam =~ s/\.(cfg|ctl|def)$//i;
        next unless $nam =~ m/^(TL|TST)\w+$/i;
        $tbl{$man.$nam.$arg} = $opt;
        ++$cnt;
      }
    }
  }
  else
  { # Prepare the execution list
    %tbl = map {$_ => $trace}
      split(/,/, $slf->get_setting('RDA_TEST', ''));
    $cnt = scalar(%tbl);
  }

  # Collect test information
  if ($cnt)
  { $slf->init($trace) unless $init++;
    foreach my $nam (sort keys(%tbl))
    { $nam =~ $re_tst;
      $slf->set_setting('TST_MAN', $1);
      $slf->set_setting('TST_ARGS', $4);
      exit(1) if $slf->collect($2, $debug, $tbl{$nam}, 0);
    }
  }
  print "\t\tNo test module\n" if $verbose && !$cnt;

  # Indicate the exit value
  $slf->get_setting('RDA_EXIT', 0);
}

# Display the version numbers
sub do_version
{ my ($slf) = @_;
  my ($cnt, $dir, $fil, $ver);

  # Force Perl package load
  eval {
    $slf->discover;
    $slf->init($trace);
    $slf->output;
    $slf->pod;
    $slf->profile;
    $slf->render;
    $slf->daemon;
  };

  # Display the RDA version
  print "RDA ", $slf->get_setting('RDA_VERSION', '?'),
    "\nCurrent directory: ", get_cwd(), "\nOS: $^O\n\n";

  # Display the version of the RDA modules
  print "VERSION OF RDA MODULES:\n";
  foreach $dir ('.', 'RDA',
    File::Spec->catdir('RDA', 'Macro'),
    File::Spec->catdir('RDA', 'Macro', 'Unix'),
    File::Spec->catdir('RDA', 'Macro', 'Windows'),
    File::Spec->catdir('RDA', 'Object'),
    'hcve',
    'modules')
  { if (opendir(DIR, $dir))
    { print $dir, ":\n";
      foreach my $nam (sort readdir(DIR))
      { next if $nam =~ m/^\./;
        if (-f ($fil = File::Spec->catfile($dir, $nam)) && open(FIL, "<$fil"))
        { $cnt = 20;
          while (<FIL>)
          { if (m/\$Id\:\s+\S+\s+(\d+)(\.(\d+))?\s/)
            { printf("%-16s%5d.%02d\n", $nam, $1, $3 || 0);
              last;
            }
            last unless --$cnt > 0;
          }
          close(FIL);
        }
      }
      closedir(DIR);
      print "\n";
    }
  }

  # Display the version of already loaded Perl modules
  print "VERSION OF LOADED PERL PACKAGES:\n";
  foreach my $mod (sort keys(%INC))
  { $dir = File::Spec->catdir(dirname($INC{$mod}));
    $dir = '.' unless $dir;
    next unless $mod =~ s/\.(pl|pm)$//;
    next unless $force || $mod !~ m/^RDA/;
    $mod =~ s/[\\\/]/::/g;
    $ver = eval "\$$mod\::VERSION" || '?';
    $ver = sprintf("%d.%02d", $1, $3 || 0) if $ver =~ m/^(\d+)(\.(\d+))?$/;
    printf("%-26s%8s %s\n", $mod, $ver, $dir);
  }
}

# Produce module cross references
sub do_xref
{ my $slf = shift;
  my ($dir, $err, $mod, $obj);

  eval "require RDA::Block";
  die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;
  eval "require RDA::Module";
  die "RDA-00010: Cannot locate required RDA modules:\n$@" if $@;

  $slf->init;
  foreach my $arg (@_)
  { print "Treating $arg ...\n" if $verbose;
    $dir = dirname($arg);
    $dir = $slf->get_info('dir') if $dir eq '.';
    $mod = basename($arg);
    if ($mod =~ m/^profiles?$/i)
    { $slf->profile->load->xref;
    }
    elsif ($mod =~ m/^rda\.cfg$/i)
    { $slf->profile->load($mod)->xref;
    }
    elsif ($mod =~ s/\.cfg$//i)
    { RDA::Module->new($mod, $dir)->xref($slf);
    }
    elsif ($mod =~ s/\.(ctl|def)$//i)
    { RDA::Block->new($mod, $dir)->xref($slf);
    }
  }
}

# Get the working directory
sub get_cwd
{ return File::Spec->catdir(getcwd());
}

# Get the module lists
sub get_mod_lists
{ my ($slf, $flg) = @_;

  (@tb_all, %tb_abr, %tb_mod) = () if $flg;

  unless (scalar(@tb_all))
  { @tb_all = $slf->get_modules;
    foreach my $nam (@tb_all)
    { $nam =~ s/\.(ctl|def)$//i;
      next if exists($tb_abr{$nam});
      $tb_abr{$nam} = $nam;
      if ($nam =~ m/^S\d{3}([A-Za-z]\w*)$/i)
      { if (!exists($tb_mod{$1}))
        { $tb_mod{$1} = $nam;
          $tb_abr{$nam} = $1;
        }
        elsif ($tb_mod{$1} ne $1)
        { my $mod = $tb_mod{$1};
          $tb_mod{$1} = $1;
          $tb_abr{$mod} = $mod;
        }
      }
    }
  }
}

sub get_tst_lists
{ my ($slf, $flg) = @_;

  (@tb_all, %tb_abr, %tb_mod) = () if $flg;

  unless (scalar(@tb_all))
  { @tb_all = $slf->get_tools;
    foreach my $nam (@tb_all)
    { $nam =~ s/\.(ctl|def)$//i;
      next if exists($tb_abr{$nam});
      $tb_abr{$nam} = $nam;
      if ($nam =~ m/^(TL|TST)(\w+)$/i)
      { if (!exists($tb_mod{$2}))
        { $tb_mod{$2} = $nam;
          $tb_abr{$nam} = $2;
        }
        elsif ($tb_mod{$1} ne $2)
        { my $mod = $tb_mod{$2};
          $tb_mod{$2} = $2;
          $tb_abr{$mod} = $mod;
        }
      }
    }
  }
}

# Create dynamic working directory
sub mk_work
{ my $dir = shift;

  if ($dir =~ s#\$\$#$$#g)
  { mkdir($dir, 0700) unless -d $dir;
    print "|RDA_WORK=$dir|\n";
  }
  $dir;
}

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2008, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut