root/juggler/branches/2.0_alpha_2/cvs-gather.pl

#!/usr/bin/env perl

# ************** <auto-copyright.pl BEGIN do not edit this line> **************
#
# Doozer++ is (C) Copyright 2000-2003 by Iowa State University
#
# Original Author:
#   Patrick Hartling
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# *************** <auto-copyright.pl END do not edit this line> ***************

# cvs-gather.pl,v 1.31 2003/07/03 16:54:54 patrickh Exp

use 5.005;

use Cwd qw(chdir getcwd);
use File::Basename;
use File::Path;
use Getopt::Long;
use Pod::Usage;

use strict 'vars';
use vars qw($indent $log_file $full_path $debug_level $override $max_cvs_tries
            $cvs_wait_length $cvs_wait_multiplier $cvs_wait_unit);
use vars qw($CRITICAL_LVL $WARNING_LVL $CONFIG_LVL $STATE_LVL $VERB_LVL
            $HVERB_LVL $HEX_LVL);

# Subroutine prototypes.
sub printVersion();
sub parse($$);
sub parseModule($$$;$);
sub handleInclude($$$);
sub expandWildcardLine($$);
sub expandWildcards($$$$$);
sub doOverride($$);
sub overrideValue($$$);
sub checkoutModules($);
sub updateModule($$$$$$);
sub checkoutModule($$$$$$$);
sub runCvsCommand($);
sub modifyCvsEntries($$);
sub expandEnvVars($);
sub printDebug($@);
sub nextSpinnerFrame($);

# *********************************************************************
# Here is the version for this script!

my $VERSION = '0.1.10';
# *********************************************************************

my $cfg_file         = '';
my $help             = 0;
my $ignore_overrides = 0;
my $print_version    = 0;
my $verbose          = 0;
my $entry_mod        = 0;
my $force_install    = 0;
my $manual           = 0;

my (@limit_modules) = ();
my (@overrides)     = ();
my (%cmd_overrides) = ();

$max_cvs_tries = 10;
my $cvs_wait   = "1s";

$CRITICAL_LVL = 0;
$WARNING_LVL  = 1;
$CONFIG_LVL   = 2;
$STATE_LVL    = 3;
$VERB_LVL     = 4;
$HVERB_LVL    = 5;
$HEX_LVL      = 6;

$debug_level = $CRITICAL_LVL;
GetOptions('cfg=s' => \$cfg_file, 'help' => \$help, 'override=s' => \@overrides,
           'ignore-overrides' => \$ignore_overrides,
           'debug=i' => \$debug_level, 'set=s' => \%cmd_overrides,
           'version' => \$print_version, 'verbose' => \$verbose,
           'entry-mod' => \$entry_mod, 'force-install' => \$force_install,
           'target=s' => \@limit_modules, 'manual' => \$manual,
           'cvs-tries=i' => \$max_cvs_tries, 'cvs-wait=s' => \$cvs_wait)
   or pod2usage(2);

# Print the help output and exit if --help was on the command line.
pod2usage(1) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $manual;

# Print the version number and exit if --version was on the command line.
printVersion() && exit(0) if $print_version;

# If we are doing verbose output and the user did not change the debug level,
# then we push the debug level up to the max.
$debug_level = $HVERB_LVL if $verbose && $debug_level <= $CRITICAL_LVL;

$cvs_wait =~ /^(\d+)(\w?)$/;
$cvs_wait_length = $1;
my $wait_unit    = "$2";

if ( "$wait_unit" == "s" )
{
   $cvs_wait_multiplier = 1;
   $cvs_wait_unit       = "second";
}
elsif ( "$wait_unit" == "m" )
{
   $cvs_wait_multiplier = 60;
   $cvs_wait_unit       = "minute";
}

if ( ! $cfg_file )
{
   if ( -r "Gatherrc" )
   {
      $cfg_file = 'Gatherrc';
   }
   elsif ( -r ".gatherrc" )
   {
      $cfg_file = '.gatherrc';
   }
   else
   {
      $cfg_file = "$ENV{'HOME'}/.gatherrc";
   }
}

$log_file = "gather.log";
open(LOG_FILE, "> $log_file")
   or warn "WARNING: Could not create log file $log_file: $!\n";

my (%orig_modules) = ();
parse("$cfg_file", \%orig_modules) or die "ERROR: Failed to parse $cfg_file\n";

# %orig_modules contains the set of modules with all options set as read from
# $cfg_file.  %override_modules is a copy of that information that will be
# passed around to doOverride() below.  In this way, we can retain the original
# module information if we need it for comparison purposes or something.  Once
# all the doOverride() calls are complete, %override_modules will contain
# exactly what the user wants in terms of modules to retrieve and what options
# should be used in the retrieval process.
my %override_modules = %orig_modules;

# If --ignore-overrides was not passed in, process any override files and
# override command-line arguments.
if ( ! $ignore_overrides )
{
   # If the list of override files is empty, try the default files.
   if ( $#overrides == -1 )
   {
      if ( -r ".gatherrc-override" )
      {
         push(@overrides, '.gatherrc-override');
      }
      elsif ( -r "$ENV{'HOME'}/.gatherrc-override" )
      {
         push(@overrides, "$ENV{'HOME'}/.gatherrc-override");
      }
   }

   # This is a global variable (argh!) that will contain the name of the
   # current override file being processed.
   $override = '';

   # Iterate over the list of override files passed in on the command line and
   # apply each of them to the current environment.
   foreach $override ( @overrides )
   {
      if ( open(OVERRIDE, "$override") )
      {
         my $line;
         while ( $line = <OVERRIDE> )
         {
            chomp($line);

            # Strip comments.
            $line =~ s/#.*$//;

            # Skip blank lines.
            next if $line =~ /^\s*$/;

            # The current line has at least one wildcard.
            if ( $line =~ /\*/ )
            {
               if ( $line !~ /\*\./ )
               {
                  warn "ERROR: Invalid wildcard use at $override:$.\n";
               }
               else
               {
                  my(@override_lines) = expandWildcardLine("$line",
                                                           \%orig_modules);

                  foreach ( @override_lines )
                  {
                     doOverride("$_", \%override_modules);
                  }
               }
            }
            # The current line has no wildcards.
            else
            {
               doOverride("$line", \%override_modules);
            }
         }

         close(OVERRIDE);
      }
      else
      {
         warn "WARNING: Could not open override file $override: $!\n";
      }
   }

   # Loop over all the command-line overrides (--set key=value arguments) and
   # apply them to the current environment.
   my $key;
   foreach $key ( keys(%cmd_overrides) )
   {
      # This is needed because expandWildcardLine() and doOverride() expect to
      # see something of the form "<key> = <value>".
      my $line = "$key = $cmd_overrides{$key}";

      # The current line has at least one wildcard.
      if ( $key =~ /\*/ )
      {
         if ( $key !~ /\*\./ )
         {
            warn "ERROR: Invalid wildcard use at $override:$.\n";
         }
         else
         {
            my(@override_lines) = expandWildcardLine("$line", \%orig_modules);

            foreach ( @override_lines )
            {
               doOverride("$_", \%override_modules);
            }
         }
      }
      # The current line has no wildcards.
      else
      {
         doOverride("$line", \%override_modules);
      }
   }
}

my (%targeted_modules) = ();

# If the list of target modules is empty, then %override_modules contains the
# module list we will use.  This hash may be different from %orig_modules
# depending on what command-line options were given.
if ( $#limit_modules == -1 )
{
   %targeted_modules = %override_modules;
}
else
{
   foreach ( @limit_modules )
   {
      if ( ! defined($override_modules{"$_"}) )
      {
         warn "WARNING: Trying to target unknown module '$_'\n";
         next;
      }

      $targeted_modules{"$_"} = $override_modules{"$_"};
   }
}

checkoutModules(\%targeted_modules);
exit 0;

# -----------------------------------------------------------------------------
# Subroutines follow.
# -----------------------------------------------------------------------------

sub printVersion ()
{
   print "$VERSION\n";

   return 1;
}

sub parse ($$)
{
   my $file       = shift;
   my $module_ref = shift;

   my $status = 1;

   open(INPUT, "$file") or die "ERROR: Could not open $file: $!\n";

   my $cfg_data = '';
   while ( <INPUT> )
   {
      $cfg_data .= $_;
   }
   close(INPUT);

   $cfg_data =~ s|/\*.*?\*/||gs; # Strip out C-style comments
   $cfg_data =~ s/#.*$//gm;      # Strip out shell-style comments
   $cfg_data =~ s|//.*$||gm;     # Strip out C++-style comments 

   my $mod_count = 0;
   while ( $cfg_data =~ /\s*(\w.*?\w?)\s*{\s*(.*?)\s*}\s*;\s*/s )
   {
      my $module_name = "$1";
      my $module_body = "$2";
      $cfg_data       = $';

      $indent = 0;
      print "Loading $module_name from $file ...\n";
      my $parse_stat = parseModule("$module_body", "$module_name", $module_ref);
      return 0 if $parse_stat == -1;
      $mod_count++
   }

   warn "WARNING: Nothing happened which probably means a parse error\n"
      unless $mod_count > 0;

   return $status;
}

sub parseModule ($$$;$)
{
   my $module_body = shift;
   my $module_name = shift;
   my $module_ref  = shift;
   my $in_module   = shift || 0;

   print " " x $indent, "Parsing $module_name\n";

   my $status = 1;

   # Ensure that all of these are initialized just for safety's sake.
   $$module_ref{"$module_name"}{'CVSROOT'} = '';
   $$module_ref{"$module_name"}{'Module'}  = [];
   $$module_ref{"$module_name"}{'Date'}    = '';
   $$module_ref{"$module_name"}{'Tag'}     = '';
   $$module_ref{"$module_name"}{'Path'}    = '.';

   # Initialize this module's dependency hash with an anonymous hash
   # reference.
   $$module_ref{"$module_name"}{'deps'} = {};

   while ( "$module_body" ne "" && $status == 1 )
   {
      printDebug $HEX_LVL, ">" x 78, "\nNew module body:\n$module_body\n",
                           "<" x 78, "\n";

      SWITCH:
      {
         # Matched an include.
         if ( $module_body =~ /^(s?include\s+(.+?);)/s )
         {
            my $inc_string = "$1";
            my $inc_file   = "$2";

            $indent += 4;
            $status = handleInclude("$inc_string", "$inc_file", \$module_body);
            $indent -= 4;

            last SWITCH;
         }

         if ( $module_body =~ /^CVSROOT:\s+(\S+?)\s*;/s )
         {
            $$module_ref{"$module_name"}{'CVSROOT'} = "$1";
            $module_body = $';
            last SWITCH;
         }

         if ( $module_body =~ /^Module:\s+(.+?)\s*;/s )
         {
            my $temp = "$1";
            $module_body = $';

            my($cvs_module_name, $install_name) = ('', '');

            if ( $temp =~ /^(.+?)\s*\[(.*)\]\s*$/ )
            {
               $cvs_module_name = "$1";
               $install_name    = "$2";
            }
            else
            {
               $cvs_module_name = "$temp";
            }

            push(@{$$module_ref{"$module_name"}{'Module'}},
                 {$cvs_module_name => $install_name});
            last SWITCH;
         }

         # Matched a tag/branch setting for this module.
         if ( $module_body =~ /^Tag:\s+(\S+?)\s*;/s )
         {
            $$module_ref{"$module_name"}{'Tag'}  = "$1";
            $module_body = $';
            last SWITCH;
         }

         # Matched a date setting for this module.
         if ( $module_body =~ /^Date:\s+(.+?)\s*;/s )
         {
            $$module_ref{"$module_name"}{'Date'}  = "$1";
            $module_body = $';
            last SWITCH;
         }

         # Matched a path setting for this module.
         if ( $module_body =~ /^Path:\s+(.+?)\s*;/s )
         {
            my $path = "$1";
            expandEnvVars(\$path);
            $$module_ref{"$module_name"}{'Path'}  = "$path";
            $module_body   = $';
            last SWITCH;
         }

         # Matched the beginning of a sub-module.
         if ( $module_body =~ /^(\w.*?\w?)\s*{\s*(.*)/s )
         {
            $indent += 4;
            ($module_body = parseModule("$2", "$1",
                                        $$module_ref{"$module_name"}{'deps'},
                                        1))
               or return 0;
            $indent -= 4;
            print " " x $indent, "Returning to $module_name\n";
            last SWITCH;
         }

         # We have reached the end of the module.
         if ( $module_body =~ /^}/ && $in_module )
         {
            print " " x $indent, "Finished parsing $module_name\n";
            return $';
         }

         warn "Parse error in the following:\n$module_body\n";
         $status = -1;
      }

      $module_body =~ s/^\s+(\S*)/$1/s;
   }

   return $status;
}

sub handleInclude ($$$)
{
   my $inc_string = shift;
   my $inc_file   = shift;
   my $text_ref   = shift;

   my $sinclude = 1 if $inc_string =~ /^sinclude/;

   my $status = 1;

   expandEnvVars(\$inc_file);

   if ( open(INC_FILE, "$inc_file") )
   {
      my $loaded_body = '';
      while ( <INC_FILE> )
      {
         $loaded_body .= $_;
      }
      close(INC_FILE);

      $$text_ref =~ s/\Q$inc_string\E/$loaded_body/s;
   }
   else
   {
      warn "WARNING: Failed to load $inc_file: $!\n" unless $sinclude;
      $$text_ref =~ s/\Q$inc_string\E//s;
      $status = 0;
   }

   return $status;
}

sub expandWildcardLine ($$)
{
   my $line       = shift;
   my $module_ref = shift;

   my (@expanded_lines) = ();

   my ($path, $value) = split(/\s*=\s*/, "$line");
   my (@path_arr)     = split(/\./, "$path");

   local $full_path = "$path";

   if ( $#path_arr < 1 )
   {
      warn "ERROR: Invalid hierarchy in $line ($override:$.)\n";
   }
   else
   {
      my (@modules) = ();

      if ( "$path_arr[0]" eq "*" )
      {
         @modules = keys(%$module_ref);
      }
      else
      {
         $modules[0] = $path_arr[0];
      }

      my $module;
      foreach $module ( @modules )
      {
         my (@work_arr) = @path_arr;
         $work_arr[0] = "$module";
         my $work_path = "$full_path";
         $work_path =~ s/^\*/$module/;

         expandWildcards(\@work_arr, $module_ref, $value, \@expanded_lines,
                         $work_path);
      }
   }

   return @expanded_lines;
}

sub expandWildcards ($$$$$)
{
   my $path_ref       = shift;
   my $module_ref     = shift;
   my $override_value = shift;
   my $lines_ref      = shift;
   my $work_path      = shift;

   my $current_value = shift(@$path_ref);
   printDebug $VERB_LVL, "current_value: $current_value\n";

   if ( "$current_value" eq "*" )
   {
      die "This should never happen!\n";
   }
   else
   {
      # A wildcard in this position (<Module>.*) must always indicate a
      # project dependency.
      if ( $$path_ref[0] && $$path_ref[0] eq "*" )
      {
         my (@temp_arr) = ();
         my ($dep_name, $new_path);

         shift(@$path_ref);
         my $save_path = $work_path;
         printDebug $VERB_LVL, "Unexpanded Path: $work_path\n";

         foreach $dep_name ( keys(%{$$module_ref{"$current_value"}{'deps'}}) )
         {
            printDebug $VERB_LVL, "Dep: $dep_name\n";
            @temp_arr = @$path_ref;
            unshift(@temp_arr, "$dep_name");
            printDebug $HVERB_LVL, "path_arr: @$path_ref\n";
            printDebug $HVERB_LVL, "temp_arr: @temp_arr\n";

            $work_path =~ s/\*/$dep_name/;
            printDebug $VERB_LVL, "New Path: $work_path\n";

            expandWildcards(\@temp_arr, $$module_ref{"$current_value"}{'deps'},
                            $override_value, $lines_ref, $work_path);
            $work_path = $save_path;
         }

         # If the above expansion gave us <Module>.<Setting>, we now have
         # only <Setting> which is meaningless.
         # XXX: It seems like this should not be necessary, but it may be the
         # result of using a different array reference in the recursive calls.
         shift(@$path_ref) if $#$path_ref == 0;
      }
      elsif ( defined($$module_ref{"$current_value"}) )
      {
         printDebug $STATE_LVL, "Matched $current_value\n";
         printDebug $VERB_LVL, "Checking for $$path_ref[0] in $current_value\n";

         # We have reached the end of the recursion.
         if ( defined($$module_ref{"$current_value"}{$$path_ref[0]}) )
         {
            printDebug $STATE_LVL,
                       "Adding line '$work_path = $override_value'\n";
            push(@$lines_ref, "$work_path = $override_value");
         }
         elsif ( defined($$module_ref{"$current_value"}{'deps'}{$$path_ref[0]}) )
         {
            printDebug $STATE_LVL, "Matched dependency $$path_ref[0]\n";
            expandWildcards($path_ref, $$module_ref{"$current_value"}{'deps'},
                            $override_value, $lines_ref, $work_path);
         }
         else
         {
            warn "WARNING: $work_path not found!\n";
         }
      }
      else
      {
         warn "WARNING: $work_path not found!\n";
      }
   }
}

sub doOverride ($$)
{
   my $line       = shift;
   my $module_ref = shift;

   my ($path, $value) = split(/\s*=\s*/, "$line");
   my (@path_arr)     = split(/\./, "$path");

   if ( $#path_arr < 1 )
   {
      warn "ERROR: Invalid hierarchy in $line ($override:$.)\n";
   }
   else
   {
      local $full_path = "$path";
      overrideValue(\@path_arr, $module_ref, "$value");
   }
}

sub overrideValue ($$$)
{
   my $path_ref       = shift;
   my $module_ref     = shift;
   my $override_value = shift;

   my $current_value = shift(@$path_ref);

   if ( defined($$module_ref{"$current_value"}) )
   {
#      print "Matched $current_value\n";
#      print "Checking for ", $$path_ref[0], " in $current_value\n";

      # We have reached the end of the recursion.
      if ( defined($$module_ref{"$current_value"}{$$path_ref[0]}) )
      {
         if ( $$path_ref[0] eq "Module" )
         {
            my $module_list = "$override_value";
            $module_list =~ s/;/ /g;

            my(@modules)       = split(/;/, "$module_list");
            my(@mod_overrides) = ();

            my $mod;
            foreach $mod ( @modules )
            {
               my($module_name, $install_name) = ('', '');

               if ( $mod =~ /^\s*(.+?)\s*\[(.*)\]\s*$/ )
               {
                  $module_name  = "$1";
                  $install_name = "$2";
               }
               else
               {
                  $module_name = "$mod";
               }

               push(@mod_overrides, {$module_name => $install_name});
            }

            print "Overriding $full_path with $module_list\n";
            $$module_ref{"$current_value"}{'Module'} = \@mod_overrides;
         }
         elsif ( $$path_ref[0] eq "Path" )
         {
            my $new_path = "$override_value";
            expandEnvVars(\$new_path);

            print "Overriding $full_path with $new_path\n";
            $$module_ref{"$current_value"}{'Path'} = "$new_path";
         }
         else
         {
            print "Overriding $full_path with $override_value\n";
            $$module_ref{"$current_value"}{$$path_ref[0]} = "$override_value";
         }
      }
      elsif ( defined($$module_ref{"$current_value"}{'deps'}{$$path_ref[0]}) )
      {
#         print "Matched dependency $$path_ref[0]\n";
         overrideValue($path_ref, $$module_ref{"$current_value"}{'deps'},
                       $override_value);
      }
      else
      {
         warn "WARNING: $full_path not found!\n";
      }
   }
   else
   {
      warn "WARNING: $full_path not found!\n";
   }
}

sub checkoutModules ($)
{
   my $mod_ref = shift;

   my $mod_name;
   foreach $mod_name ( keys(%$mod_ref) )
   {
      my $module = '';
      foreach $module ( @{$$mod_ref{"$mod_name"}{'Module'}} )
      {
         my($cvs_module_name, $install_name) = each(%$module);

         if ( defined($$mod_ref{"$mod_name"}{'CVSROOT'}) && $cvs_module_name )
         {
            # If a module is already checked out, update it instead of doing
            # a new checkout.
            if ( ($install_name &&
                    -d "$$mod_ref{$mod_name}{'Path'}/$install_name") ||
                 -d "$$mod_ref{$mod_name}{'Path'}/$cvs_module_name" )
            {
               updateModule("$mod_name", $$mod_ref{"$mod_name"}{'Tag'},
                            $$mod_ref{"$mod_name"}{'Date'},
                            $$mod_ref{"$mod_name"}{'Path'},
                            "$cvs_module_name", "$install_name");
            }
            else
            {
               printDebug $VERB_LVL, "$mod_name --> ",
                          "$$mod_ref{$mod_name}{'CVSROOT'} ",
                          "$$mod_ref{$mod_name}{'Tag'} ",
                          "$$mod_ref{$mod_name}{'Date'} ",
                          "$cvs_module_name (to $$mod_ref{$mod_name}{'Path'}";
               printDebug $VERB_LVL, "/$install_name" if $install_name;
               printDebug $VERB_LVL, ")\n";

               checkoutModule($mod_name, $$mod_ref{"$mod_name"}{'CVSROOT'},
                              $$mod_ref{"$mod_name"}{'Tag'},
                              $$mod_ref{"$mod_name"}{'Date'},
                              "$cvs_module_name",
                              $$mod_ref{"$mod_name"}{'Path'},
                              "$install_name");
            }
         }
      }

      checkoutModules($$mod_ref{"$mod_name"}{'deps'});
   }
}

sub updateModule ($$$$$$)
{
   my $name         = shift;
   my $tag          = shift;
   my $date         = shift;
   my $path         = shift;
   my $cvs_module   = shift;
   my $install_name = shift;

   my $module = ("$install_name" ne "") ? "$install_name" : "$cvs_module";

   print "Updating $name ($module) in $path ...\n";

   my $cur_dir = getcwd();
   chdir("$path") if "$path" ne "" && "$path" ne ".";

   my $status;

   if ( chdir("$module") )
   {
      my $cmd_line = "cvs update ";

      # If we are updating on the HEAD branch and no date is specified, use
      # 'cvs update -A' to remove any sticky tags that may exist from an
      # earlier update or checkout.
      if ( "$tag" eq "HEAD" && ! $date )
      {
         $cmd_line .= "-A ";
      }
      # If we are not updating on the HEAD branch or a date is given, then we
      # need extra arguments to get sticky tags put into place.