Subversion Repositories DevTools

########################################################################

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

# Module name   : jats_deploy_builder.pl

# Module type   : Makefile system

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : Extract Data from RM in order to generate a deployment

#                 structure

#

#                 Creates a directory structure and maintain symlinks

#

# Usage:        See POD

#

#......................................................................#

require 5.008_002;

use strict;

use warnings;

use Pod::Usage;

use Getopt::Long;

use POSIX qw(strftime);

use File::Path;

use File::Basename;

use JatsError;

use JatsSystem;

use Getopt::Long;

use Pod::Usage;

use JatsRmApi;

use ArrayHashUtils;

use DBI;

use JatsEnv;

use FileUtils;

my $VERSION = "1.0.0";

our $GBE_DPKG;

our $GBE_UNIX;

my $RM_DB;

my $opt_verbose = 0;

my $opt_help = 0;

my $opt_manual;

my $opt_outdir = 'tmp';

my $opt_outdirFin;

my $opt_outdirTmp;

my $opt_flat = 1;

my $opt_quiet;

my $opt_deepDebs = 0;

my $opt_dpkg_archive;

my $opt_relativeLinks = 1;

#

#   Data Items

#

my $startTime = strftime("%F %T", localtime);

my $progName = basename($0);

my @DeployData;

my %data;

#-------------------------------------------------------------------------------

# Function        : Main Entry

#

# Description     :

#

# Inputs          :

#

# Returns         :

#

{

    my $result = GetOptions (

                    "help+"             => \$opt_help,          # flag, multiple use allowed

                    "manual"            => \$opt_manual,        # flag

                    "verbose:+"         => \$opt_verbose,       # flag

                    "quiet:+"           => \$opt_quiet,         # flag

                    "outdir:s"          => \$opt_outdir,        # String

                    "dpkg_archive:s"    => \$opt_dpkg_archive,  # String

                    "flat!"             => \$opt_flat,          # flag

                    "relativelinks!"    => \$opt_relativeLinks, # flag

                    "deepDebian!"       => \$opt_deepDebs,      # flag

                    );

    #

    #   Process help and manual options

    #

    pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);

    pod2usage(-verbose => 1)  if ($opt_help == 2 );

    pod2usage(-verbose => 2)  if ($opt_manual || ($opt_help > 2));

    ErrorConfig( 'name'    =>'DplyBuild', 

                 'verbose' => $opt_verbose,

                 'quiet'   => $opt_quiet);

    #

    #   Sanity Check

    #

    EnvImport('GBE_DPKG');

    EnvImport('GBE_UNIX');

    Error("This program does not run under Windows","Windows cannot create Symbolic Links")

        unless ($GBE_UNIX);

    #

    #   Validate the path to dpkg_archive

    #

    if ($opt_dpkg_archive)

    {

        Error("dpkg_archive is not a directory") 

            unless -d $opt_dpkg_archive;

        $GBE_DPKG = $opt_dpkg_archive;

    }

    #

    #   Check that the parent of the base directory exists

    #   Check that the CWD is not within the target directory 

    #   If the output directory exists - check they we created it

    #       Try to prevent users from kill entire directory trees

    #

    InitFileUtils();

    my $pdir = FullPath( catdir($opt_outdir, '..') );

    my $udir = StripDir($opt_outdir);

    Error ("Cannot create deployment sets in non existent directory","Parent directory must exist", $pdir) 

        unless(-d $pdir);

    my $rdir = RelPath( FullPath($opt_outdir));

    Error ("Cannot create deployment sets in a parent of the current directory")

        if ($rdir eq '..' || $rdir eq '.' || $rdir =~ m~/\.\.$~);

    if (-d $opt_outdir)

    {

        Error("Cannot create deployment sets into a directory not created by this utility", catdir($opt_outdir,'.deploy_builder'))

            unless (-f catdir($opt_outdir,'.deploy_builder'));

    }

    #

    #   Convert the user-provided base directory into a real path - one that does

    #   not contain any symlinks. Need a physical path to correctly calculate relative

    #   paths.

    #

    my $realPath = Realpath($pdir);

    $opt_outdir = catdir($realPath, $udir);

    #

    #   Set up paths for a build and swap

    #       $opt_outdirFin - The final output directory

    #       $opt_outdir    - Working (tmp) output directory

    #       $opt_outdirTmp - Temp output. Used in renaming

    #

    $opt_outdirFin = $opt_outdir;

    $opt_outdir = join('.', $opt_outdir, 'tmp' );

    $opt_outdirTmp = join('.', $opt_outdir, 'tmp' ); 

    if (-d $opt_outdir && ! -f catdir($opt_outdir, '.deploy_builder')) {

        Error("Working directory not created by this utility", $opt_outdir)

    }

    if (-d $opt_outdirTmp && ! -f catdir($opt_outdirTmp, '.deploy_builder')) {

        Error("Temp directory not created by this utility", $opt_outdirTmp)

    }

    # Cleanout working directories

    #   We have verified the we created them

    #

    RmDirTree($opt_outdirTmp);

    RmDirTree($opt_outdir);

    #

    #   Do the body of the work

    #

    GetPkgInfo();

    createDirectories();

    createReports();

#DebugDumpData("data", \%data);

    #

    #   Swap in new directory structure

    #   Try to do it as fast as possible

    #       Rename the existing directory

    #       Rename the working directory

    #       Then delete what we need to delete

    #

    rename($opt_outdirFin,$opt_outdirTmp) if (-d $opt_outdirFin);

    rename($opt_outdir, $opt_outdirFin);

    RmDirTree($opt_outdir);

    RmDirTree($opt_outdirTmp);

    #

    #   All done

    #

    exit 0;

}

#-------------------------------------------------------------------------------

# Function        : populateHash 

#

# Description     : Put an array of data items into a hash

#                   Clean white space from the data

#

# Inputs          : pHash           - ref to output hash

#                   pRow            - Ref to the row data 

#                   pItems          - Ref to an hash array of entry names

# Returns         : pHash

#

sub populateHash

{

    my ($pHash, $pRow, $pItems) = @_;

    foreach my $item ( @{$pItems} ) {

        my $data = shift @{$pRow};

        if (defined $data)

        {

            $data =~ s~^\s+~~;

            $data =~ s~\s+$~~;

            $pHash->{$item} = $data;

        }

    }

    return $pHash;

}

#-------------------------------------------------------------------------------

# Function        : performSqlQueryCallback 

#

# Description     : Perform a general Sql query and invoke a user function for

#                   each row of results

#

# Inputs          : $fname                  - Name of query for error reporting

#                   $m_sqlstr               - Query string

#                   $f_process              - Function called for each row in the result

#                                             Use closure to have callback modify other data

#

# Returns         : Number of rows found

#

sub performSqlQueryCallback

{

    my ($fname, $m_sqlstr, $f_process ) = @_;

    my $found = 0;

    connectRM(\$RM_DB) unless $RM_DB;

    $m_sqlstr =~ s~\s+~ ~g;

    Verbose3("SQL:", $m_sqlstr);

    my $sth = $RM_DB->prepare($m_sqlstr);

    if ( defined($sth) )

    {

        if ( $sth->execute( ) )

        {

            if ( $sth->rows )

            {

                while ( my @row = $sth->fetchrow_array )

                {

                    $found++;

                    &$f_process(\@row);

                }

            }

            $sth->finish();

        }

        else

        {

            Error("$fname:Execute failure: $m_sqlstr", $sth->errstr() );

        }

    }

    else

    {

        Error("$fname:Prepare failure" );

    }

    unless ( $found )

    {

        Warning("$fname:No data found");

    }

    return $found;

}

#-------------------------------------------------------------------------------

# Function        : populateArrayFromSql 

#

# Description     : Issue an SQL query and push the results into an array of hashes

#                   where each row from the query is a hash and the entire result is an 

#                   array 

#

# Inputs          :     name                - For error reporting

#                       pArray              - Ref to the output array

#                       sql                 - Sql to process

#                       pItems              - Array of tems to extract

#                                             Must match the SQL SELECT arguments

#                                             Item names starting with '-' do not end up in the

#                                             generated XML

# Returns         : 

#

sub populateArrayFromSql

{

    my ($fname, $pArray, $m_sqlstr, $pItems) = @_;

    performSqlQueryCallback($fname, 

                            $m_sqlstr, 

                            sub { 

                                my ($pRow) = @_;

                                Verbose3("$fname:" . join(',',@$pRow));

                                my %entry;

                                push @{$pArray}, populateHash( \%entry, $pRow, $pItems);

                                }

                            );

#DebugDumpData("populateArrayFromSql", $pArray);

}

#-------------------------------------------------------------------------------

# Function        : GetPkgInfo  

#

# Description     : Get Basic Package Information    

#

# Inputs          : pHash               - Ref to Hash to populate 

#

# Returns         : 

#

sub GetPkgInfo

{

    my ($pHash) = @_;

    my $fname = 'GetPkgInfo';

    #

    #   Now extract the package infromation

    #

    my @items = qw(pkgName version pvid rtagid projName releaseName official );

    my $m_sqlstr =  "select pkg.pkg_name, pv.pkg_version, pv.pv_id, rt.rtag_id, prj.proj_name, rt.rtag_name, rt.official".

                    " from release_manager.package_versions pv,".

                    "      release_manager.packages pkg,".

                    "      release_manager.release_content rc,".

                    "      release_manager.release_tags rt,".

                    "      release_manager.projects prj".

                    " where pkg.pkg_id = pv.pkg_id".

                    " and prj.proj_id = rt.proj_id".

                    " and pv.is_deployable = 'Y' and pv.dlocked = 'Y'".

                    " and rc.pv_id = pv.pv_id".

                    " and rt.rtag_id = rc.rtag_id".

                    " and rt.official not in ( 'Y', 'A' )";

    populateArrayFromSql( $fname, \@DeployData, $m_sqlstr, \@items );

#    DebugDumpData("$fname", \@DeployData);

}

#-------------------------------------------------------------------------------

# Function        : cleanName 

#

# Description     : Create a 'nice' file/directory name

#                       Remove / and \

#                       Remove known Swedish characeters

#                       Remove mumtiple _

#

# Inputs          : $arg            - Unclean element

#

# Returns         : Clean Element

#

sub cleanName

{

    my ($arg) = @_;

    $arg =~ s~[/\\]~-~g;

    $arg =~ tr~åÅäÄöÖéÉ~aAaAoOeE~s;

    $arg =~ tr~_~~s;

    $arg =~ tr~-~~s;

    return $arg;

}

#-------------------------------------------------------------------------------

# Function        : createDirectories 

#

# Description     : Given a (global) data structure - create the output

#                   directory structure

#

# Inputs          : 

#

# Returns         : 

#

my %seen;

sub createDirectories

{

    #

    #   Delete the existing directory tree

    #

    mkpath($opt_outdir);

    TouchFile(catdir($opt_outdir, '.deploy_builder'));

    foreach my $entry ( @DeployData) {

#        print("$entry->{pkgName} $entry->{version}\n");

        # Clean up names

        my $projName = cleanName($entry->{projName});

        my $releaseName = cleanName($entry->{releaseName});

        #

        #   Create a hash with ProjectName:ReleaseName:PackageName:PackageVersion

        #

        $data{$projName}{$releaseName}{$entry->{pkgName}}{$entry->{version}}{'noDpkg'} = 1;

        #

        #   Determine source files

        #

        my $pkgDir = catdir($GBE_DPKG, $entry->{pkgName}, $entry->{version});

        if ( -d $pkgDir)

        {

            delete $data{$projName}{$releaseName}{$entry->{pkgName}}{$entry->{version}}{'noDpkg'};

#            print("$pkgDir\n");

            #

            #   Most Deployable package export build artifacts in the root directory

            #   They are installers after all

            #   The exception are debian packages

            #       Assume that they will be in bin/XXXX/*.deb

            #

            opendir (my $dh, $pkgDir) || Error ("Cannot open $pkgDir: $!");

            while ( $_ = readdir $dh)

            {

                next if(m~^\.~);

                next if(m~^built.~);

                next if(m~^descpkg~);

                my $fname = catdir($pkgDir, $_);

                scanDebian($fname,$projName,$releaseName,$entry->{pkgName},$entry->{version}) 

                    if (m~^bin$~ && $opt_deepDebs);

                next if( -d $fname );

                #

                #   Scan for allowed file types

                #       Defined as regexps

                #

                my @allowedExtensions = qw( \.pkg.gz$ \.exe$ \.msi$ \.deb$ ^IzPack-.*\.jar$ );

                my $allowed;

                foreach my $ext ( @allowedExtensions) {

                    if ( m~$ext~i)

                    {

                        $allowed = $ext;

                        last;

                    }

                }

                #

                #   Specifically exclude some files

                #

                if ($allowed)

                {

                    foreach my $name ( qw(^setup\.exe$ ^setup\.msi$)) {

                        if ( m~$name~i)

                        {

                            $allowed = 0;

                            last;

                        }

                    }

                }

                if ($allowed)

                {

                    addDeployedFile($_, $fname,$projName,$releaseName,$entry->{pkgName},$entry->{version});

                }

                else

                {

                    IgnoreFile($_, $fname,$projName,$releaseName,$entry->{pkgName},$entry->{version});

                }

            }

            closedir $dh;

        }

        else

        {

            # Warn about missing packages once

            unless (exists ($seen{$entry->{pkgName}}{$entry->{version}})) {

                $seen{$entry->{pkgName}}{$entry->{version}}++;

                Warning("Package Not found: $entry->{pkgName}, $entry->{version}");

            }

        }

    }

}

#-------------------------------------------------------------------------------

# Function        : addDeployedFile 

#

# Description     : Add the specified file to the deployed area

#

# Inputs          : $name

#                   $target

#                   $projName

#                   $releaseName

#                   $pkgName

#                   $version 

#

# Returns         : 

#

sub addDeployedFile

{

    my ($name, $target, $projName, $releaseName, $pkgName, $version) = @_;

    my $tdir;

    push @{$data{$projName}{$releaseName}{$pkgName}{$version}{files}}, $target;

    Verbose("deploy: $target");

    #

    #   Create a flat directory structure

    #       Project/Release/Files ...

    #

    if ($opt_flat) {

        $tdir = catdir($opt_outdir,$projName,$releaseName);

    } else {

        $tdir = catdir($opt_outdir,$projName,$releaseName,$pkgName,$version );

    }

    mkpath($tdir);

    # Convert Absolute path to relative path

    if ($opt_relativeLinks) {

        my $base = $target;

        $target = RelPath( $target, AbsPath($tdir));

        my $relPathTest = catdir($tdir, $target);

        Error ("Relative path calculation error",

               "Possible case. One of the elements of the output path is a symlink",

               $base, AbsPath($tdir), $target, $relPathTest) 

            unless -f $relPathTest;

    }

    my $linkDone = eval{ symlink( $target, catdir($tdir,$name)); 1};

    Error ("Target file system does not appear to support symlinks") 

        unless $linkDone;

#    print("$_\n");

}

sub IgnoreFile

{

    my ($name, $target, $projName, $releaseName, $pkgName, $version) = @_;

    Warning("Ignore: $target");

    push @{$data{$projName}{$releaseName}{$pkgName}{$version}{ignored}}, $target;

}

#-------------------------------------------------------------------------------

# Function        : scanDebian 

#

# Description     : Scan for debian packages

#                   Assumes that $target is the 'bin' directory

#

#                   Will only transfer files from one of 'P' or the 'D' directory

#                   cannot transfer from both as the generated debian packages will

#                   have the same name

#

# Inputs          : $target

#                   $projName

#                   $releaseName

#                   $pkgName

#                   $version 

#

# Returns         : 

#

sub scanDebian

{

    my ($target, $projName, $releaseName, $pkgName, $version) = @_;

    my %binTargetType;

    my %binTargets;

    #

    #   Locate directorues under bin

    #   Build up a hash splitting out the P and D

    #

    opendir (my $dh, $target) || Error ("Cannot open $target: $!");

    while ($_ = readdir $dh)

    {

        next if(m~^\.~);

        next unless (m~(.*)([PD])$~);

        my $platform = $1;

        my $type = $2;

        my $binDir = catdir($target, $_);

        if (-d $binDir)

        {

            unless(exists $binTargetType{$platform}{P})

            {

                $binTargets{$platform} = $binDir;

                $binTargetType{$platform}{$type} = 1; 

            }

        }

    }

    closedir $dh;

    foreach my $binDir (values(%binTargets))

    {

        opendir (my $dh, $binDir) || Error ("Cannot open $binDir: $!");

        while ($_ = readdir $dh)

        {

            next if(m~^\.~);

            next unless (m~\.deb$~);

            my $debFile = catdir($binDir, $_);

            addDeployedFile($_,$debFile,$projName, $releaseName, $pkgName, $version);

        }

        closedir $dh;

    }

}

#-------------------------------------------------------------------------------

# Function        : createReports 

#

# Description     : Add a report into each Release directory to describe the

#                   success and failure of the deployment

#

# Inputs          : 

#

# Returns         : 

#

sub createReports

{

    my $printHdr;

    my $ofile;

    foreach my $projName ( sort keys %data) {

        foreach my $releaseName ( sort keys %{$data{$projName}}) {

            $printHdr = 0;

            my $odir = catdir($opt_outdir,$projName,$releaseName);

            if (-d $odir)

            {

                $ofile = catdir($odir, 'build_report.txt');

            }

            else

            {

                $ofile = catdir($opt_outdir, join('-',$projName,$releaseName,'build_report.txt'));

                $printHdr = 1;

            }

            open (my $oh , '>', $ofile  ) || Warning("Cannot open $ofile. $!");

            print $oh ("Project: $projName\n");

            print $oh ("Release: $releaseName\n");

            print $oh ("Created: $startTime\n");

            print $oh ("Created by: $progName\n");

            print $oh ("This project has not deployed any files\n") if $printHdr;

            $printHdr = 0;

            foreach my $pkgName (sort keys %{$data{$projName}{$releaseName}}) {

                foreach my $version (sort keys %{$data{$projName}{$releaseName}{$pkgName}}) {

                    next unless $data{$projName}{$releaseName}{$pkgName}{$version}{noDpkg};

                        print $oh ("\nThe following packages do not exist in dpkg_archive\n") unless $printHdr;

                        $printHdr = 1;

                        print $oh ("    $pkgName, $version\n");

                }

            }

            $printHdr = 0;

            foreach my $pkgName (sort keys %{$data{$projName}{$releaseName}}) {

                foreach my $version (sort keys %{$data{$projName}{$releaseName}{$pkgName}}) {

                    next if $data{$projName}{$releaseName}{$pkgName}{$version}{noDpkg};

                    next if $data{$projName}{$releaseName}{$pkgName}{$version}{files};

                    print $oh ("\nThe following packages do contribute any files\n") unless $printHdr;

                    $printHdr = 1;

                    print $oh ("    $pkgName, $version\n");

                }

            }

            foreach my $pkgName (sort keys %{$data{$projName}{$releaseName}}) {

                foreach my $version (sort keys %{$data{$projName}{$releaseName}{$pkgName}}) {

                    next unless $data{$projName}{$releaseName}{$pkgName}{$version}{ignored};

                    print $oh ("\nIgnored Files from Package: $pkgName, $version\n");

                    foreach my $ifile (sort @{$data{$projName}{$releaseName}{$pkgName}{$version}{ignored}}) {

                        $ifile =~ s~$GBE_DPKG/~~;

                        print $oh ("    $ifile\n");

                    }

                }

            }

            print $oh ("\nFile List:\n");

            foreach my $pkgName (sort keys %{$data{$projName}{$releaseName}}) {

                foreach my $version (sort keys %{$data{$projName}{$releaseName}{$pkgName}}) {

                    next unless $data{$projName}{$releaseName}{$pkgName}{$version}{files};

                    print $oh ("$pkgName, $version\n");

                    foreach my $tfile (sort @{$data{$projName}{$releaseName}{$pkgName}{$version}{files}}) {

                        $tfile =~ s~$GBE_DPKG/~~;

                        print $oh ("    $tfile\n");

                    }

                }

            }

        close $oh;

        }

    }

}

#-------------------------------------------------------------------------------

#   Documentation

#

=pod

=for htmltoc    SYSUTIL::

=head1 NAME

jats_deploy_builder - Build Deployment package sets

=head1 SYNOPSIS

 jats jats_deploy_builder [options]

 Options:

    -help              - Brief help message

    -help -help        - Detailed help message

    -man               - Full documentation

    -verbose[=n]       - Display additional progress messages

    -quiet[=n]         - Supress output

    -[no]flat          - Control output structure. Default noflat

    -[no]deepDebian    - Dig debian packages from BIN directories

    -[no]relativeLinks - Create Relative or Absolute symlinks

    -dpkg_archive=path - Path the dpkg_archive

    -outdir=name       - Root of the output directory

=head1 OPTIONS

=over 8

=item B<-help>

Print a brief help message and exits.

=item B<-help -help>

Print a detailed help message with an explanation for each option.

=item B<-man>

Prints the manual page and exits.

=item B<-quiet[=n]>

This option suppresses normal output. It is intended to allow the program to be run

within a 'cron' job. Only errors will generate output to be mailed to some user.

Use a value of 3 to supress warnings.

=item B<-[no]flat>

Control the output directory format. The default is noflat.

The flat structure places all the files in one directory under the 'release' directory.

The noflat structure creates package-name/package-version subdirectories 

under the 'release' directory.

=item B<-[no]deepDebian>

Dig debian packages from BIN directories. The default is to assume the correct deployable 

package format - with all deployable packages in the root of the package

=item B<-[no]relativeLinks>

This option control the type of link created between the deployed file set and dpkg_archive.

The default operation is to create relative symlinks.

=item B<-dpkg_archive=path>

This option specifies the path to dpkg_archive; where packages will be found. If provided 

this value will be used otherwise it will be taken from the environment variable GBE_DPKG.

=item B<-outdir=name>

This option specifies the root of the output directory tree created by this tool.

If the directory exists it may be deleted. The entire directory subtree is in the 

domain of this application.

If not provided then the program will use a directory of 'tmp' within the users current

woking directory.

=back

=head1 DESCRIPTION

This utility program is create and maintain a set of deployed packages for all active releases

defined within the Release Manager Database.

The tool is intended to facilitate the continuous deployment process by maintaining

a collection or depeloyed packages. See 'update_release' utility for other operations.

The utility will:

=over 4

=item * 

Locate all active releases in the Release Manager database

It will ignore closed and archived releases.

=item * 

Locate all released packages that are marked as 'deployable'

=item * 

Create a directory structure 

The directory structure is of the form: 'Project Name/Release Name'.

If the 'noflat' mode has been selected, then the structure under the 'release' 

directory will also contain the package-name/package-version.

=item *

Transfer deployable artifacts (see below) from each package into the release subdirectory.

The utilty will create symbolic links to the actual packages within dpkg_archive. 

=item *

Create a 'build_report.txt' file for each release processed. 

If processing actually created and populated a 'release' directory, then the report will

be in the 'release' directory, otherwise it will be created in the base of the target 

directory and will be prefixed with the Project and Release name.

The report details:

=over 4

=item * 

Date Time that the package set was created

=item * 

Packages that did not contribute any files to the output

=item * 

Packages that do not exist in dpkg_archive

=item * 

Ignored files

=back

=back

=head2 Deployable Artifacts

The utilty will only process files that it considers to be depoyable. These are:

=over 4

=item * 

Suitable files in the root of the package

These are:

=over 4

=item * 

Solaris Packages: *.pkg.gz

=item * 

Windows executable installers: *.exe

=item * 

Windows installers: *.msi

=item * 

Debian Packages: *.deb

=item * 

IzPack Pqackages: IzPack-*.jar

=back

The concept is that only these files are deployable.

=item * 

If the -deepDebian option is given, then Debian packages found within subdirectores 

of the 'bin' directory will be located.

Debian packages that are to be deployed should be built to follow the deployable

convention. Unfortunately many have not been. This tool attampts to cater for this bad

practice. It will examine all directories with the 'bin' subdirectory and locate one 

of the production or debug builds. It will then transfer debians packages from the 

found directory. Preference is given to production versions.

This process is required as the debug and production versions have the same name.

=back

=head1 EXAMPLE

=head2 jats deploy_builder -outdir=/export/devl/releases/current

This will mainatin the package sets in the '/export/devl/releases/current' directory.

=cut