view release on metacpan or  search on metacpan

devmgr/dev_rls_tool  view on Meta::CPAN

$VERSION = do {my @r=(q$Revision: 1.14 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
$revision = q{$Id: dev_rls_tool,v 1.14 2000/05/26 21:48:31 idsweb Exp $ };

exit show_version if (grep(/-version/i, @ARGV));

#
# These are the names that the tool is known by. These pseudo-constants are
# used instead of strings so that changes can be made, here, once.
#
$MAIN     = 'dev_rls_tool';
$STAGE    = 'stage';
$POPULATE = 'populate';
$RELEASE  = 'release';

#
# Set up a hash table for the valid lists of options keyed by the command name.
# In case of failure or -h, call a subroutine. With four different names to be
# called by, a traditional $USAGE string just doesn't hack it...
#
%valid_opts = (
               $RELEASE  => [ qw(-u=s -save -noxfer -update -stage -prod) ],
               $STAGE    => [ qw(-t=s -r=s -full -notag) ],
               $POPULATE => [ qw(-t=s -r=s) ],
               $MAIN     => [ qw(-d=s) ],
              );
Getopt::Long::config 'no_ignore_case';
exists($valid_opts{$cmd}) or die usage('unknown');
GetOptions(\%opts, (@{$valid_opts{$cmd}},
                    # These are common options to all forms
                    qw(-D=i -h -e=s -force -cvsroot=s -debug -verbose -terse
                       -log=s)))
    or die usage($cmd) . "\nStopped";
if ((defined $opts{h} and $opts{h}) or ($cmd ne $MAIN and ! @ARGV))
{
    print STDOUT usage($cmd) . "\n";
    exit 0;
}

#
# Force a false for all the boolean options, so that tests involving them
# don't produce "use of uninitialized value" warnings
#
grep($opts{$_} |= 0, qw(update stage prod force debug verbose terse));

#
# Simple default values used pretty much globally
#
$bin_dir = dirname $0;
($log_dir = $bin_dir) =~ s/ahp-bin/local/o;
$log_dir =~ s{/?suid_scripts}{};
$LOGFILE = $opts{'log'} || "$log_dir/dev_release.log";
# Undocumented incremental debugging option:
$DEBUG = $opts{D} || 0;
$DEBUG |= 1 if ($opts{debug});
STDOUT->autoflush;

#
# Save ourselves some repeated primitive operations by caching them here:
#
$opts{date} = scalar localtime;
$opts{user} = $ENV{LOGNAME} || (getpwuid($>))[0] || getlogin;
$opts{wmpassword} = $ENV{WMPASSWD} || '';

#
# Set up more extensive die()- and warn()-handlers
#
$SIG{__DIE__}  = sub {
                     chomp $_[0];
                     write_log_line($LOGFILE, "$opts{date} [$$] $_[0]");
                     die "$_[0]\n";
                 };
$SIG{INT}  = sub {
                     chomp $_[0];
                     write_log_line($LOGFILE, "$opts{date} [$$] $_[0]");
                     die "$_[0]\n";
                 };
$SIG{HUP}  = sub {
                     chomp $_[0];
                     write_log_line($LOGFILE, "$opts{date} [$$] $_[0]");
                     die "$_[0]\n";
                 };
$SIG{__WARN__} = sub {
                     chomp $_[0];
                     write_log_line($LOGFILE, "$opts{date} [$$] $_[0]");
                     warn "$_[0]\n";
                 };

#
# Special case: some of the steps below can only be done after the tool is
# initialized, so we handle the "main" cases specially
#
exit (do_admin(@ARGV)) if ($cmd eq $MAIN);

#
# Set this up so that an error condition doesn't inadvertently leave the 
# project in a locked state
#
END
{
    #
    # This relies on the various do_* routines to put the lockfile name into
    # %CONFIG under this name.
    #
    if (defined($CONFIG{lockfile}) and $CONFIG{lockfile})
    {
        unlink $CONFIG{lockfile};
    }
}

#
# Get any host-specific configuration:
#
read_config_file \%CONFIG;

#
# Set the value that the ACL modules used for a base directory:
#
if (defined $CONFIG{ACL_DIR})
{
    if ($CONFIG{ACL_DIR} !~ m|^/|)
    {
        my $homedir = ($CONFIG{OWNER} =~ /^\d+$/) ?
            (getpwuid($CONFIG{OWNER}))[7] :
            (getpwnam($CONFIG{OWNER}))[7];

        $CONFIG{ACL_DIR} = "$homedir/$CONFIG{ACL_DIR}";
    }

    ACL_dir $CONFIG{ACL_DIR};
}
elsif (-d "$log_dir/etc/acl")
{
    ACL_dir "$log_dir/etc/acl";
}
# Else use the default from IMS::ReleaseMgr::Access

#
# Read the release-host information from the database:
#
read_hostconfig \%HOSTS;

#
# Create the table of files that should be excluded, including a special regex
# for some cases.
#
for (qw(TOPICLIST WEBLIST RELEASE BUILDLIST))
{
    unless (exists $CONFIG{$_})
    {
        $CONFIG{$_} = '.' . lc $_;
    }
    $exclude_files{$CONFIG{$_}} = 1;
}
# Regex
$exclude_files{__RE__} = '(^#.*|~$)';

#
# Assign any other default %CONFIG values
#
$CONFIG{CVS} = $CONFIG{CVS} || 'cvs';

#
# Force the CVS root to be in the environment variable CVSROOT. This saves a
# fair amount of overhead in terms of always testing the config/env values.
#
if (defined($opts{cvsroot}) and $opts{cvsroot})
{
    $ENV{CVSROOT} = $opts{cvsroot};
}
elsif (defined($CONFIG{CVSROOT}) and $CONFIG{CVSROOT})
{
    $ENV{CVSROOT} = $CONFIG{CVSROOT};
}
elsif (! defined($ENV{CVSROOT}))
{
    die "$cmd: No CVSROOT found, please set the environment or use -cvsroot\n";
}

#
# Use this table to call the apropos routine based on the name by which this
# tool was called. "$MAIN" was handled earlier, so it is absent here.
#
%called_as = (

devmgr/dev_rls_tool  view on Meta::CPAN

#
#   Returns:        Success:    void
#                   Failure:    dies
#
###############################################################################
sub read_hostconfig
{
    my $table = shift;

    my ($buf, $data);

    $data = DBI_all_mirrors;
    unless (defined $data)
    {
        die "$cmd: read_hostconfig: Error getting full mirror data table: " .
            DBI_error . "\n";
    }
    write_log_line($LOGFILE,
                   sprintf("$opts{date} [$$] DBI mirror data read: %d hosts",
                           scalar(keys %$data)))
        if ($DEBUG & 14); # bxxxx111x

    %$table = %$data;
    return;
}

###############################################################################
#
#   Sub Name:       test_for_halt
#
#                   Since this routine is called for almost all invocations,
#                   it is not in the SelfLoader section.
#
#   Description:    Check to see if this particular command has been 
#                   temporarily disabled with a halt-file. If it has, display
#                   the halt-file contents (if any) on STDOUT.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $cmd      in      scalar    Name by which we were called
#
#   Globals:        $LOGFILE
#                   $DEBUG
#                   %opts
#                   %CONFIG
#
#   Environment:    None.
#
#                   NOTE NON-STANDARD RETURN LOGIC
#   Returns:        Success:    0, no halt file
#                   Failure:    1, program needs to stop
#
###############################################################################
sub test_for_halt
{
    my $cmd = shift;

    my $prefix = $CONFIG{HALTFILE_PREFIX};
    unless (defined $prefix and $prefix)
    {
        my $home = ($CONFIG{OWNER} =~ /^\d+$/o) ?
            (getpwuid($CONFIG{OWNER}))[7] : (getpwnam($CONFIG{OWNER}))[7];
        unless (defined $home and $home)
        {
            warn "$cmd: test_for_halt: Could not find haltfiles area, " .
                "skipping\n";
            return 0;
        }

        $prefix = "$home/etc/halt-";
    }
    if (! $prefix =~ m|^/|o)
    {
        my $home = ($CONFIG{OWNER} =~ /^\d+$/o) ?
            (getpwuid($CONFIG{OWNER}))[7] : (getpwnam($CONFIG{OWNER}))[7];
        unless (defined $home and $home)
        {
            warn "$cmd: test_for_halt: Could not find haltfiles area, " .
                "skipping\n";
            return 0;
        }

        $prefix = "$home/$prefix";
    }

    my $file = "${prefix}$cmd";
    if (-e $file)
    {
        #
        # There is a haltfile. If it is not zero-length, echo it to STDOUT. If
        # the user is a member of group $CONFIG{GROUP}, they can use -force to
        # override this.
        #
        if (defined $opts{force})
        {
            my $userlist = ($CONFIG{GROUP} =~ /^\d+$/o) ?
                (getgrgid($CONFIG{GROUP}))[3] : (getgrnam($CONFIG{GROUP}))[3];
            my @userlist = split(/ /, $userlist);

            return 0 if (grep($_ eq $opts{user}, @userlist));
            warn "$cmd: You are not authorized to use the -force option\n";
        }
        if (-s $file) # size != 0
        {
            my $fh = new IO::File "< $file";

            if (! defined $fh)
            {
                warn "$cmd haltfile $file exists but is unreadable: $!\n";
                return 1;
            }

            print STDOUT "Command $cmd currently under a halt:\n\n";
            print STDOUT <$fh>;
            print STDOUT "\nMembers of group $CONFIG{GROUP} can use -force\n";
            print STDOUT "to override this.\n";
            $fh->close;
        }

        return 1;
    }

    # No haltfile, no worries
    0;
}

__END__

###############################################################################
#
#   Sub Name:       deduce_host
#
#   Description:    Using the known hosts in the global hash %HOSTS, try to
#                   find the most-recently-staged host for $project
#