FileList.pm
Modules
- Archive::Tar
- Compress::Zlib
- IMS::ReleaseMgr
Functions:
Main Script
Variables:
 - $Id
- $Revision
- $TAR
- $VERSION
- $basedir
- $error_text
- $files
- $mirror
- $project
- $revision
- $user
- %02d
- %d
- %inc_dirs
- @EXPORT
- @EXPORT_OK
- @ISA
- @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: FileList_doc.html,v 1.1 2000/05/04 21:14:15 idsweb Exp $
#
#   Description:    Provide an interface by which an application can have files
#                   written locally while also arranging for them to be
#                   propagated to any mirrors of this host.
#
#   Functions:      upload_files
#                   error
#
#   Libraries:      IMS::ReleaseMgr
#
#   Global Consts:  $VERSION            Version information for this module
#                   $revision           Copy of the RCS revision string
#
#   Environment:    None.
#
###############################################################################
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
###############################################################################
#
#   Sub Name:       upload_files
#
#   Description:    Take the list of files, along with other parameters, and
#                   create a properly-crafted tar file which is then managed
#                   via IMS::ReleaseMgr::new().
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $user     in      scalar    Authenticated user name
#                   $mirror   in      scalar    Mirror group
#                   $project  in      scalar    Name of the project that data
#                                                 is for.
#                   $basedir  in      scalar    Base directory path element(s)
#                                                 under $project for files to
#                                                 be put into
#                   $files    in      hashref   Hash table reference for the
#                                                 files. Keys are file names
#                                                 (rel. to $project/$basedir)
#                                                 and values are either local
#                                                 file names or IO::File refs.
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    0
#
###############################################################################/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: FileList_doc.html,v 1.1 2000/05/04 21:14:15 idsweb Exp $
#
#   Description:    Provide an interface by which an application can have files
#                   written locally while also arranging for them to be
#                   propagated to any mirrors of this host.
#
#   Functions:      upload_files
#                   error
#
#   Libraries:      IMS::ReleaseMgr
#
#   Global Consts:  $VERSION            Version information for this module
#                   $revision           Copy of the RCS revision string
#
#   Environment:    None.
#
###############################################################################
package IMS::ReleaseMgr::FileList;
use 5.002;
use strict;
use vars           qw(@ISA @EXPORT @EXPORT_OK $VERSION $revision
                      $error_text $TAR %inc_dirs);
use subs           qw(upload_files error);
use Carp;
use File::Path     qw(mkpath rmtree);
use File::Copy     qw(copy);
use File::Basename qw(dirname);
use Cwd            qw(cwd);
require Exporter;
require IO::File;
require IMS::ReleaseMgr;
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
$revision = q$Id: FileList_doc.html,v 1.1 2000/05/04 21:14:15 idsweb Exp $;
$error_text = '';
$TAR = '/bin/tar';
@ISA = qw(Exporter);
@EXPORT = qw(upload_files error);
@EXPORT_OK = @EXPORT;
%inc_dirs = (
             'www.interactive.hp.com' => '/opt/ims/incoming',
             'www.dmo.hp.com'         => '/usr/local/etc/httpd/incoming',
             'www.shopping.hp.com'    => '/opt/ims/incoming',
             'www.buy.hp.com',        => '/opt/ims/www.buy.hp.com/incoming'
            );
1;
###############################################################################
#
#   Sub Name:       upload_files
#
#   Description:    Take the list of files, along with other parameters, and
#                   create a properly-crafted tar file which is then managed
#                   via IMS::ReleaseMgr::new().
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $user     in      scalar    Authenticated user name
#                   $mirror   in      scalar    Mirror group
#                   $project  in      scalar    Name of the project that data
#                                                 is for.
#                   $basedir  in      scalar    Base directory path element(s)
#                                                 under $project for files to
#                                                 be put into
#                   $files    in      hashref   Hash table reference for the
#                                                 files. Keys are file names
#                                                 (rel. to $project/$basedir)
#                                                 and values are either local
#                                                 file names or IO::File refs.
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    0
#
###############################################################################
sub upload_files
Variables:
 - $PKG
- $TAR
- $WL
- $_
- $basedir
- $cwd
- $dir
- $directory
- $err
- $file
- $files
- $inc_dirs
- $line
- $mirror
- $project
- $revision
- $tmpdir
- $tmptar
- $user
- %s
- @_
Calls:
-  abort
- close
- commit
- data
- error
- new
- remove
- validate
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: FileList_doc.html,v 1.1 2000/05/04 21:14:15 idsweb Exp $
#
#   Description:    Provide an interface by which an application can have files
#                   written locally while also arranging for them to be
#                   propagated to any mirrors of this host.
#
#   Functions:      upload_files
#                   error
#
#   Libraries:      IMS::ReleaseMgr
#
#   Global Consts:  $VERSION            Version information for this module
#                   $revision           Copy of the RCS revision string
#
#   Environment:    None.
#
###############################################################################
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};
###############################################################################
#
#   Sub Name:       upload_files
#
#   Description:    Take the list of files, along with other parameters, and
#                   create a properly-crafted tar file which is then managed
#                   via IMS::ReleaseMgr::new().
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $user     in      scalar    Authenticated user name
#                   $mirror   in      scalar    Mirror group
#                   $project  in      scalar    Name of the project that data
#                                                 is for.
#                   $basedir  in      scalar    Base directory path element(s)
#                                                 under $project for files to
#                                                 be put into
#                   $files    in      hashref   Hash table reference for the
#                                                 files. Keys are file names
#                                                 (rel. to $project/$basedir)
#                                                 and values are either local
#                                                 file names or IO::File refs.
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    0
#
###############################################################################/n/n     #
    # basic data sanity checks:
    #
    # Make a 'clean' base, without extra // or /./
    #
    # Get a name for a temp dir that isn't already in use
    #
        # Leading / not really a problem, but remove them along with trailing
        #
        # Create any needed subdirectories
        #
        # If this is not an ordinary scalar-string (name):
        # Again, if this is not an ordinary scalar-string (name):
    # Write a weblist for this soon-to-be tar file
    print $WL "# weblist generated for $user by $revision, " .
    #
    # Now create the tar file
    #
    #
    # Expect to replace this with Archive::Tar soon
    #
    #
    # Later, we'll make this more flexible...
    #
    #
    # Successfully processed
    #
    undef $PKG; # Force destructor now, rather than at exit
Code:
 {
    my ($user, $mirror, $project, $basedir, $files) = @_;
    my ($tmpdir, $tmptar, $cwd, $file, $WL, $PKG, $directory);
    #
    # basic data sanity checks:
    #
    if ($project !~ /^([\w\-\+])+$/o)
    {
        error "The project name ($project) may only contain alphanumerics, " .
            "- and +";
        return 0;
    }
    if ($basedir =~ /\.\./o)
    {
        error "The base-directory specification ($basedir) may not contain " .
            "any occurrances of ``..''";
        return 0;
    }
    if (grep(/\.\./o, (keys %$files)))
    {
        error "The file name specifications may not contain any occurrances " .
            "of ``..''";
        return 0;
    }
    # Make a 'clean' base, without extra // or /./
    $basedir =~ s|^/||go;
    $basedir =~ s|/$||go;
    $basedir =~ s|/\./|/|go;
    $basedir =~ s|//|/|go;
    #
    # Get a name for a temp dir that isn't already in use
    #
    $tmpdir = "/tmp/irMfL-$$";
    $tmpdir++ while (-e $tmpdir);
    umask 02;
    mkpath("$tmpdir/$project/$basedir", 0, 0775);
    $cwd = cwd;
    for $file (sort keys %$files)
    {
        # Leading / not really a problem, but remove them along with trailing
        $file =~ s|^/||go;
        $file =~ s|/$||go;
        #
        # Create any needed subdirectories
        #
        if ($file =~ m|/|o)
        {
            my $dir = dirname $file;
            mkpath "$tmpdir/$project/$basedir/$dir", 0, 0775;
        }
        # If this is not an ordinary scalar-string (name):
        seek($files->{$file}, 0, 0) if (ref $files->{$file});
        if (! copy($files->{$file}, "$tmpdir/$project/$basedir/$file"))
        {
            error "Copy failed to file $tmpdir/$project/$basedir/$file: $!";
            rmtree $tmpdir;
            return 0;
        }
        # Again, if this is not an ordinary scalar-string (name):
        seek($files->{$file}, 0, 0) if (ref $files->{$file});
        chmod 0644, "./$file";
    }
    # Write a weblist for this soon-to-be tar file
    $WL = new IO::File "> $tmpdir/$project/weblist";
    unless (defined $WL)
    {
        error "Could not open $tmpdir/$project/weblist for writing: $!";
        rmtree $tmpdir;
        return 0;
    }
    print $WL "# weblist generated for $user by $revision, " .
        (scalar localtime) . "\n";
    print $WL (map
           {
               ($file = $_) =~ s|^/||go;
               $file =~ s|/$||go;
               $file =~ s|//|/|go;
               $file =~ s|/\./|/|go;
               $file = ($basedir) ? "$basedir/$file" : $file;
               sprintf("%s\t%s\t%s\n",
                       ($file =~ /(jpg|gif|pdf)$/oi) ? 'Fig' : 'Doc',
                       $file, "/$project/" . dirname $file);
           }
               sort (keys %$files));
    $WL->close;
    #
    # Now create the tar file
    #
    chdir $tmpdir;
    if ($?)
    {
        error "Could not chdir to $tmpdir: $!";
        chdir $cwd;
        rmtree $tmpdir;
        return 0;
    }
    #
    # Expect to replace this with Archive::Tar soon
    #
    system("$TAR cf $project.tar $project 2>&1 > /dev/null");
    $? >>= 8;
    if ($?)
    {
        error "System error executing ``$TAR cf $project.tar $project'': $!";
        chdir $cwd;
        rmtree $tmpdir;
        return 0;
    }
    #
    # Later, we'll make this more flexible...
    #
    $directory = $inc_dirs{$mirror} || '/tmp';
    $PKG = new IMS::ReleaseMgr(name      => $project,
                               user      => $user,
                               nomail    => 1,
                               file      => "$tmpdir/$project.tar",
                               directory => $directory);
    unless (defined $PKG)
    {
        error "Unable to create upload package";
        chdir $cwd;
        rmtree $tmpdir;
        return 0;
    }
    unless ($PKG->validate)
    {
        my ($err, $file, $line) = $PKG->error;
        $PKG->abort;
        error "Package upload error detected at $file, line $line: $err";
        chdir $cwd;
        rmtree $tmpdir;
        return 0;
    }
    unless ($PKG->commit)
    {
        my ($err, $file, $line) = $PKG->error;
        $PKG->abort;
        error "Package upload error detected at $file, line $line: $err";
        chdir $cwd;
        rmtree $tmpdir;
        return 0;
    }
    #
    # Successfully processed
    #
    $PKG->close;
    undef $PKG; # Force destructor now, rather than at exit
    error '';
    1;
}
Variables:
 
Calls:
Comments:
 
 ###############################################################################
#
#   Sub Name:       error
#
#   Description:    Get/set the message associated with the most recent error
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $text     in      scalar    If passed, set the error text
#                                                 to this before returning.
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        current error text
#
###############################################################################/n/n 
Code:
 {
    my $text = shift;
    $IMS::ReleaseMgr::FileList::error_text = $text
        if (defined $text and $text);
    $IMS::ReleaseMgr::FileList::error_text;
}