ReleaseMgr.pm

Modules

Functions:


Main Script

Variables:

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:

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;
}


Function: validate

Variables:

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;
}


Function: error

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:

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;
}


Function: commit

Variables:

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;
}


Function: cleanup

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;
}


Function: close

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;
}


Function: abort

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;
}


Function: DESTROY

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;
}