ReleaseMgr.pm
Modules
- Archive::Tar
- Compress::Zlib
Functions:
Main Script
Variables:
- $Id
- $Revision
- $VERSION
- $class
- $revision
- $version
- %02d
- %args
- %d
- %opts
- @r
Calls:
Comments:
###############################################################################
#
# Confidential
# Disclosure And Distribution Solely to Employees of
# Hewlett-Packard and Its Affiliates Having a Need to Know
#
# Copyright @ 1998, Hewlett-Packard, Inc.,
# All Rights Reserved
#
###############################################################################
#
# @(#)$Id: ReleaseMgr_doc.html,v 1.1 2000/05/04 21:14:17 idsweb Exp $
#
# Description: This module is designed for the purpose of abstracting the
# Perl <-> Release Manager interface, specifically for the
# sake of Perl applications that need to create packages that
# Release Manager is expected to find and deploy.
#
# Functions: new
# validate
# error
# sync
# commit
# cleanup
# close
# abort
# DESTROY
#
# Libraries: None.
#
# Global Consts: $VERSION Version information for this module
# $revision Copy of the RCS revision string
#
# Environment: None.
#
###############################################################################
# This first one is used for tests to see that we have a recent-enough version
$version = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
###############################################################################
#
# Sub Name: new
#
# Description: Object constructor. Checks that sufficient information
# was provided in the argument list, and if so creates the
# new object, blesses, and copies data from %args to the
# object.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $class in varies Identifies the class to bless
# into. May be a string (a
# static constructor) or an
# existing object of this class
# (dynamic constructor).
# %opts in list All the remaining input
# elements auto-converted into
# this hash for checking.
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: new reference to object
# Failure: undef
#
###############################################################################/n
Code:
###############################################################################
#
# Confidential
# Disclosure And Distribution Solely to Employees of
# Hewlett-Packard and Its Affiliates Having a Need to Know
#
# Copyright @ 1998, Hewlett-Packard, Inc.,
# All Rights Reserved
#
###############################################################################
#
# @(#)$Id: ReleaseMgr_doc.html,v 1.1 2000/05/04 21:14:17 idsweb Exp $
#
# Description: This module is designed for the purpose of abstracting the
# Perl <-> Release Manager interface, specifically for the
# sake of Perl applications that need to create packages that
# Release Manager is expected to find and deploy.
#
# Functions: new
# validate
# error
# sync
# commit
# cleanup
# close
# abort
# DESTROY
#
# Libraries: None.
#
# Global Consts: $VERSION Version information for this module
# $revision Copy of the RCS revision string
#
# Environment: None.
#
###############################################################################
package IMS::ReleaseMgr;
use 5.004;
use strict;
use vars qw($VERSION $version $revision);
use Carp;
use IO::File;
require Archive::Tar;
# This first one is used for tests to see that we have a recent-enough version
$VERSION = 1.11;
$version = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
$revision =
q{$Id: ReleaseMgr_doc.html,v 1.1 2000/05/04 21:14:17 idsweb Exp $ };
1;
###############################################################################
#
# Sub Name: new
#
# Description: Object constructor. Checks that sufficient information
# was provided in the argument list, and if so creates the
# new object, blesses, and copies data from %args to the
# object.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $class in varies Identifies the class to bless
# into. May be a string (a
# static constructor) or an
# existing object of this class
# (dynamic constructor).
# %opts in list All the remaining input
# elements auto-converted into
# this hash for checking.
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: new reference to object
# Failure: undef
#
###############################################################################
sub new
Function: new
Variables:
- $_
- $class
- $hour
- $mday
- $min
- $mon
- $old
- $opts
- $self
- $val
- $year
- %02d
- %opts
- @_
- @list
Calls:
Comments:
###############################################################################
#
# Confidential
# Disclosure And Distribution Solely to Employees of
# Hewlett-Packard and Its Affiliates Having a Need to Know
#
# Copyright @ 1998, Hewlett-Packard, Inc.,
# All Rights Reserved
#
###############################################################################
#
# @(#)$Id: ReleaseMgr_doc.html,v 1.1 2000/05/04 21:14:17 idsweb Exp $
#
# Description: This module is designed for the purpose of abstracting the
# Perl <-> Release Manager interface, specifically for the
# sake of Perl applications that need to create packages that
# Release Manager is expected to find and deploy.
#
# Functions: new
# validate
# error
# sync
# commit
# cleanup
# close
# abort
# DESTROY
#
# Libraries: None.
#
# Global Consts: $VERSION Version information for this module
# $revision Copy of the RCS revision string
#
# Environment: None.
#
###############################################################################
# This first one is used for tests to see that we have a recent-enough version
$version = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
###############################################################################
#
# Sub Name: new
#
# Description: Object constructor. Checks that sufficient information
# was provided in the argument list, and if so creates the
# new object, blesses, and copies data from %args to the
# object.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $class in varies Identifies the class to bless
# into. May be a string (a
# static constructor) or an
# existing object of this class
# (dynamic constructor).
# %opts in list All the remaining input
# elements auto-converted into
# this hash for checking.
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: new reference to object
# Failure: undef
#
###############################################################################/n/n #
# Check for the required arguments in the passed-in values
#
#
# This approach lets new() work correctly whether called as
#
# $val = new IMS::ReleaseMgr
# -or-
# $val = IMS::ReleaseMgr->new
# -or-
# $val = $old->new
#
# when $old is an object of this class.
#
# The file option takes precedence over filehandle
# Not required at this point, because commit() can override it
#
# Handle any/all e-mail addresses specified
#
#
# Other misc. special-purpose options
#
#
# Date/time stamp
#
#
# Initialize a few other fields so that tests of them don't generate
# noise under -w.
#
Code:
{
my $class = shift;
my %opts = @_;
#
# Check for the required arguments in the passed-in values
#
if (! exists $opts{name})
{
carp "new: missing required parameter ``name'', ";
return undef;
}
unless (exists $opts{file} or exists $opts{filehandle})
{
carp "new: one of ``file'' or ``filehandle'' parameters must be " .
'specified, ';
return undef;
}
#
# This approach lets new() work correctly whether called as
#
# $val = new IMS::ReleaseMgr
# -or-
# $val = IMS::ReleaseMgr->new
# -or-
# $val = $old->new
#
# when $old is an object of this class.
#
$class = ref($class) || $class;
my $self = bless {}, $class;
$self->{name} = $opts{name};
# The file option takes precedence over filehandle
if (exists $opts{file})
{
$self->{file} = $opts{file};
$self->{filehandle} = undef;
}
else
{
$self->{filehandle} = $opts{filehandle};
$self->{file} = undef;
}
# Not required at this point, because commit() can override it
$self->{directory} = $opts{directory} || '';
#
# Handle any/all e-mail addresses specified
#
$self->{email} = '';
$self->{email} = $opts{email} if (defined $opts{email} and $opts{email});
if (defined $opts{emails} and ref($opts{emails}) eq 'ARRAY')
{
my @list = @{$opts{emails}};
$self->{email} .= " @list" if (scalar @list);
}
$self->{email} =~ tr/, /,/s;
$self->{email} =~ s/^,//o;
$self->{dest} = $opts{dest} if defined $opts{dest};
#
# Other misc. special-purpose options
#
$self->{other_opts} = {};
for (keys %opts)
{
$self->{other_opts}->{$_} = $opts{$_} unless (exists $self->{$_});
}
#
# Date/time stamp
#
my ($min, $hour, $mday, $mon, $year) = (localtime)[1 .. 5];
$hour %= 100; $mon++;
$self->{datestamp} = sprintf("%02d%02d%02d-%02d%02d",
$year, $mon, $mday, $hour, $min);
#
# Initialize a few other fields so that tests of them don't generate
# noise under -w.
#
for (qw(validated error_text error_file error_line ark_temp_file))
{
$self->{$_} = undef;
}
$self;
}
Variables:
- $bad_lines
- $file
- $line
- $opts
- $self
- $verbose
- $weblist_seen
- %opts
- @_
- @bad_lines
- @contents
- @parts
Calls:
Comments:
###############################################################################
#
# Sub Name: validate
#
# Description: Verify the data in the archive portion of the object.
# If the archive was specified as a filehandle, it is first
# written to a temporary file (which is noted for future
# operations).
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# $%opts in list Options passed in
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: $self
# Failure: undef
#
###############################################################################/n/n # Ensures that there is a physical file to tar tf on
#
# Control the verbosity of the error text
#
#
# Choose the file to read (a passed-in file would take precendence over
# the temp file from a filehandle argument) and pass it to Archive::Tar
#
# Just in case some project use Weblist rather than weblist
Code:
{
my $self = shift;
my %opts = @_;
my ($line, @contents, @parts, @bad_lines, $bad_lines, $weblist_seen);
$self->{validated} = 0;
# Ensures that there is a physical file to tar tf on
return undef if (! defined($self->sync));
#
# Control the verbosity of the error text
#
my $verbose = (defined $opts{verbose} and $opts{verbose}) ? 1 : 0;
#
# Choose the file to read (a passed-in file would take precendence over
# the temp file from a filehandle argument) and pass it to Archive::Tar
#
my $file = $self->{file} || $self->{ark_temp_file} || undef;
if (! defined $file)
{
$self->error("Panic error! No file found, but should exist at this " .
"point. Something is wrong.", __FILE__, __LINE__);
return undef;
}
$weblist_seen = $bad_lines = 0;
@contents = Archive::Tar->list_archive($file);
for $line (@contents)
{
if ($line =~ /symbolic link/o)
{
$bad_lines++;
push(@bad_lines, "SYMLINKS NOT ALLOWED: $line") if ($verbose);
}
if ($line =~ /\.\./o)
{
$bad_lines++;
push(@bad_lines, "NO ``..'' IN PATHS: $line") if ($verbose);
}
if ($line =~ m| /|o)
{
$bad_lines++;
push(@bad_lines, "ABSOLUTE PATH NOT ALLOWED: $line") if ($verbose);
}
# Just in case some project use Weblist rather than weblist
$weblist_seen++ if ($line =~ m|/[Ww]eblist|o);
}
if ($bad_lines)
{
if ($verbose)
{
$self->error("Insecure entries detected in tar archive:\n" .
join(', ', @bad_lines), __FILE__, __LINE__);
}
else
{
$self->error('Insecure entries detected in tar archive',
__FILE__, __LINE__);
}
}
elsif (! $weblist_seen)
{
$self->error('No weblist file found in the tar archive',
__FILE__, __LINE__);
}
else
{
$self->error('', '', '');
$self->{validated} = 1;
}
return ($self->{validated}) ? $self : undef;
}
Variables:
Calls:
Comments:
###############################################################################
#
# Sub Name: error
#
# Description: Return/set error text.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# $text in scalar If exists and is defined, set
# $file in scalar the error vaules to this.
# $line in scalar
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: text (possibly null)
# Failure: no failure possibility
#
###############################################################################/n/n #
# Return nothing if wantarray returns undef (void context), return just
# the text if wantarray is false (scalar context) and return the triple
# if it is true.
#
Code:
{
my $self = shift;
my $text = shift;
my $file = shift;
my $line = shift;
$self->{error_text} = $text if (defined $text);
$self->{error_file} = $file if (defined $file);
$self->{error_line} = $line if (defined $line);
#
# Return nothing if wantarray returns undef (void context), return just
# the text if wantarray is false (scalar context) and return the triple
# if it is true.
#
return if (! defined wantarray);
return ((wantarray) ?
($self->{error_text}, $self->{error_file}, $self->{error_line}) :
($self->{error_text}));
}
Function: sync
Variables:
- $buffer
- $bytesread
- $infile
- $out_fh
- $self
- $tempfile
Calls:
Comments:
###############################################################################
#
# Sub Name: sync
#
# Description: Ensure that any temporary data is in sync with changes,
# etc., prior to a commit operation. Usually just called by
# commit() or validate(), though should not be a problem if
# called multiple times.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: $self
# Failure: undef
#
###############################################################################/n/n no strict 'refs'; # In case the filehandle is a symbolic ref
# Pick a tempfile name using PID and package name
# In case of strays or other instances of this class in this process
# Open for reading and writing, with initial truncation
#
# Save these for future ease-of-use
#
Code:
{
my $self = shift;
return $self if (defined $self->{syncronized} and $self->{synchronized});
if (defined $self->{file} and $self->{file})
{
$self->{synchronized} = 1;
}
elsif (defined $self->{ark_temp_fh} and $self->{ark_temp_fh})
{
seek $self->{ark_temp_fh}, 0, 0;
$self->{synchronized} = 1;
}
elsif (defined $self->{filehandle} and $self->{filehandle})
{
no strict 'refs'; # In case the filehandle is a symbolic ref
# Pick a tempfile name using PID and package name
my $tempfile = '/tmp/' . __PACKAGE__ . "-$$-00";
# In case of strays or other instances of this class in this process
$tempfile++ while (-e $tempfile);
# Open for reading and writing, with initial truncation
my $out_fh = new IO::File "+> $tempfile";
if (! defined $out_fh)
{
$self->error("Error opening $tempfile for read/write: $!",
__FILE__, __LINE__);
return undef;
}
my $bytesread;
my $buffer = '';
my $infile = $self->{filehandle};
while ($bytesread = read($infile, $buffer, 1024))
{
print $out_fh $buffer;
}
#
# Save these for future ease-of-use
#
$self->{ark_temp_file} = $tempfile;
$self->{ark_temp_fh} = $out_fh;
seek $self->{ark_temp_fh}, 0, 0;
$self->{synchronized} = 1;
}
else
{
$self->error('sync: unable to locate input file or input filehandle',
__FILE__, __LINE__);
return undef;
}
$self->error('', '', '');
$self;
}
Variables:
- $_
- $basename
- $buffer
- $bytesread
- $infofile
- $ofh
- $opts
- $other_opts
- $revision
- $self
- $tarfile
- %opts
- %other_opts
- @_
Calls:
Comments:
###############################################################################
#
# Sub Name: commit
#
# Description: Commit the data that this object refers to to the pre-
# determined place. Basically moves the archive to the
# release manager area, and writes the info file in the
# same directory.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# %opts in list Any passed-in arguments
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: $self
# Failure: undef
#
###############################################################################/n/n #
# This is deliberate! We do not want to just rename the file, as
# there is no way of knowing what is going on outside of this module,
# and that's a tough side-effect for the end-user to code around.
#
# Success-- undef this object element for the sake of close()
#
# If we've reached this point, then the tar file is OK, and we need only
# write the info file.
#
# Destination is the target subdir of the server root. Defaults to the
# project name. The leading slash is added later.
#
print $ofh "# $self->{name} release ticket - " . (scalar localtime) . "\n";
print $ofh "# Written by $revision\n";
# Do these now, since the old-style checksum has to be last
Code:
{
my $self = shift;
my %opts = @_;
use File::Copy qw(copy move);
$self->{directory} = $opts{directory}
if (defined $opts{directory} and $opts{directory});
unless (defined $self->{directory} and $self->{directory})
{
$self->error('No directory specified for commit operation',
__FILE__, __LINE__);
return undef;
}
unless (defined $self->{validated} and $self->{validated})
{
$self->error('Package must be validated before being committed',
__FILE__, __LINE__);
return undef;
}
my ($tarfile, $infofile, $ofh, $bytesread, $buffer, $basename);
($basename = $self->{name}) =~ s/[\s\*\+\&\!\$\(\)]/_/g;
$tarfile = "$self->{directory}/$basename-$self->{datestamp}.tar";
$tarfile .= '.gz' if ((defined $self->{compressed}) and
($self->{compressed} =~ /yes|true|[1-9]/i));
$infofile = "$self->{directory}/$self->{name}-$self->{datestamp}.info";
$self->sync;
if (defined $self->{file} and ($self->{file} ne $tarfile))
{
#
# This is deliberate! We do not want to just rename the file, as
# there is no way of knowing what is going on outside of this module,
# and that's a tough side-effect for the end-user to code around.
#
if (! copy($self->{file}, $tarfile))
{
$self->error("Copy error, $self->{file} to $tarfile: $!",
__FILE__, __LINE__);
return undef;
}
}
elsif (defined $self->{ark_temp_file})
{
if (defined $self->{ark_temp_fh})
{
close $self->{ark_temp_fh};
$self->{ark_temp_fh} = undef;
}
if (! move($self->{ark_temp_file}, $tarfile))
{
$self->error("Copy error, $self->{ark_temp_file} to $tarfile: $!",
__FILE__, __LINE__);
return undef;
}
# Success-- undef this object element for the sake of close()
$self->{ark_temp_file} = undef;
}
else
{
$self->error('Unable to create the physical tar archive from input',
__FILE__, __LINE__);
return undef;
}
#
# If we've reached this point, then the tar file is OK, and we need only
# write the info file.
#
# Destination is the target subdir of the server root. Defaults to the
# project name. The leading slash is added later.
#
my %other_opts = %{$self->{other_opts}};
$self->{dest} = $self->{dest} || $self->{destination} ||
$other_opts{dest} || "/$self->{name}";
delete $other_opts{dest};
$self->{user} = $self->{user} || $other_opts{user};
delete $other_opts{user};
$self->{name} = $self->{name} || $other_opts{name};
delete $other_opts{name};
$self->{email} = $self->{email} || $other_opts{email};
delete $other_opts{email};
$ofh = new IO::File "> $infofile";
if (! defined $ofh)
{
$self->error("Unable to open $infofile for writing: $!",
__FILE__, __LINE__);
unlink $tarfile;
return undef;
}
print $ofh "# $self->{name} release ticket - " . (scalar localtime) . "\n";
print $ofh "# Written by $revision\n";
print $ofh "Info:dest\t$self->{dest}\n";
print $ofh "Info:email\t$self->{email}\n";
print $ofh "Info:name\t$self->{name}\n";
print $ofh "Info:user\t$self->{user}\n";
print $ofh "Info:nomail\tyes\n"
if (defined $self->{nomail} and $self->{nomail});
print $ofh "Info:compressed\t$self->{compressed}\n"
if (defined $self->{compressed});
if (defined $opts{noupload} and $opts{noupload})
{
print $ofh "Info:upload\tno\n"
}
else
{
print $ofh "Info:upload\tyes\n"
}
# Do these now, since the old-style checksum has to be last
print $ofh (map { "Info:$_\t$other_opts{$_}\n" }
(keys %other_opts));
if (defined $self->{crc})
{
print $ofh "$self->{crc}\n";
}
$ofh->close;
$self->{committed} = 1;
$self->{tarfile} = $tarfile;
$self->{infofile} = $infofile;
$self->error('', '', '');
$self;
}
Variables:
Calls:
Comments:
###############################################################################
#
# Sub Name: cleanup
#
# Description: Perform clean-up activities such as clearing out temp
# files, etc. Mainly a placeholder in case future expansion
# needs it. This shouldn't be needed by users of the module,
# it should be enough for them to call close(), which calls
# this.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# %opts in hash Named params to the function
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: $self
# Failure: undef
#
###############################################################################/n/n #
# The nodelete option to this method is to suppress this deletion
# of temp files. For debugging purposes, mainly.
#
Code:
{
my $self = shift;
my %opts = @_;
if (defined $self->{ark_temp_fh} and $self->{ark_temp_fh})
{
close($self->{ark_temp_fh});
delete $self->{ark_temp_fh};
}
if (defined $self->{ark_temp_file} and $self->{ark_temp_file})
{
#
# The nodelete option to this method is to suppress this deletion
# of temp files. For debugging purposes, mainly.
#
unless (defined $opts{nodelete} and $opts{nodelete})
{
unlink $self->{ark_temp_file} if (-e $self->{ark_temp_file});
delete $self->{ark_temp_file};
}
}
$self->error('', '', '');
$self;
}
Variables:
Calls:
Comments:
###############################################################################
#
# Sub Name: close
#
# Description: Close out the object. Call cleanup() to make sure any
# stray bits are cleaned out, then set the flag that the
# destructor checks.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# %opts in hash Named parameters, probably
# filtered through from some-
# where else. This routine as
# published should have no opts
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: $self
# Failure: undef
#
###############################################################################/n/n
Code:
{
my $self = shift;
my %opts = @_;
$self->cleanup(%opts);
$self->{closed} = 1;
$self->error('', '', '');
$self;
}
Variables:
Calls:
Comments:
###############################################################################
#
# Sub Name: abort
#
# Description: Unconditionally destroy this object and free up any temp
# material. Used when an error condition requires exit after
# validation but prior to disk committment.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
# %opts in hash Options passed to this routine
#
# Globals: None.
#
# Environment: None.
#
# Returns: 1
#
###############################################################################/n/n # Pass any opts on to close(), which will pass them along to cleanup()
delete $self->{validated}; # This suppresses the noise from DESTROY
Code:
{
my $self = shift;
my %opts = @_;
# Pass any opts on to close(), which will pass them along to cleanup()
$self->close(%opts) if (defined $self->{validated} and $self->{validated});
delete $self->{validated}; # This suppresses the noise from DESTROY
1;
}
Variables:
Calls:
Comments:
###############################################################################
#
# Sub Name: DESTROY
#
# Description: Before freeing up the object, make sure that any data
# was properly saved/committed/etc. beforehand. Complain
# loudly if it wasn't.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
#
# Globals: None.
#
# Environment: None.
#
# Returns: doesn't, really...
#
###############################################################################/n/n
Code:
{
my $self = shift;
if (defined $self->{validated} and $self->{validated})
{
unless (defined $self->{committed} and $self->{committed})
{
warn "IMS::ReleaseMgr::DESTROY -- freeing object that has not " .
"been committed to disk, ";
}
unless (defined $self->{closed} and $self->{closed})
{
warn "IMS::ReleaseMgr::DESTROY -- freeing object that has not " .
"been properly closed/cleaned, ";
}
}
undef $self;
}