Rev 7326 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.## Module name : create_dpkg.pl# Module type : Makefile system# Compiler(s) : Perl# Environment(s): jats## Description : This script is used to create a dpkg_archive.# Features:# * No user interaction# * Generates files list for ReleaseNote integration# * Can generate package fragemts as a tarball for build system## Usage: : See POD##......................................................................#require 5.008_002;# Include Standard Perl Functions#use strict;use warnings;use Cwd;use Getopt::Long;use File::Basename;use File::Find;use File::Path;use File::Copy;use Pod::Usage;use Digest::MD5;use XML::Simple;use Encode qw(decode encode);use JatsError;use JatsEnv;use DescPkg;use FileUtils;use JatsSystem;use JatsVersionUtils;## Under Windows we need the Win32::FileSecurity module# It only exists under windows#my $Win32 = eval "require Win32::FileSecurity";# define Global variables#my $VERSION = "3.0.0";my $PROGNAME = "create_dpkg.pl";# Globals imported from environment#our $GBE_MACHTYPE;our $GBE_HOSTNAME;our $USER;our $GBE_ABT;# Global variables#my $DPKG_NAME = "";my $DESC_NAME = "";my $DPKG_VERSION = "";my $DPKG_PRJ = "";my $DESCPKG_FILE = "";my $DESCPKG_TYPE = "";my $CWD_DIR = cwd;my $SRC_ROOT;my $DPKG_DIR;my $DPKG_ROOT;my $PKG_BASE;my $bad_merge_count = 0;my @bad_symlinks;my @fileList;my $descPkgCount = 0;my @tmpFiles;## Option variables#my $opt_help = 0;my $opt_manual = 0;my $opt_verbose = 0;my $opt_quiet = 0;my $opt_delete = 0;my $opt_override = 0;my $opt_merge = 0;my $opt_archive;my $opt_generic;my $opt_pname;my $opt_pversion;my $opt_test;my $opt_md5 = 1;my $opt_outfile;my $opt_info;my $opt_tarmode;my $opt_testArchive;my $opt_noBuild;my $opt_keepTemp;## Structure to translate -archive=xxx option to archive variable# These are the various dpkg_archives known to JATS#my %Archive2Var =( 'main' => 'GBE_DPKG','store' => 'GBE_DPKG_STORE','cache' => 'GBE_DPKG_CACHE','local' => 'GBE_DPKG_LOCAL','sandbox' => 'GBE_DPKG_SBOX','deploy' => 'GBE_DPLY','replica' => 'GBE_DPKG_REPLICA','escrow' => 'GBE_DPKG_ESCROW',);#------------------------------------------------------------------------------#------------------------------------------------------------------------------# Subroutines#------------------------------------------------------------------------------#------------------------------------------------------------------------------#------------------------------------------------------------------------------sub LogFileOp## Description:# This sub-routine is used to generate a consistent informational log#------------------------------------------------------------------------------{my ($opr, $file) = @_;$file =~ s/\Q$DPKG_DIR\E/PKGDIR/;$file =~ s/\Q$DPKG_ROOT\E/DPKG/;$file =~ s/\Q$SRC_ROOT\E/PKG/;$file =~ s/\Q$CWD_DIR\E/CWD/;Information (sprintf( "%-15s [%s]", $opr, $file));}#-------------------------------------------------------------------------------# Function : addFile## Description : Add a file to the list of transferred files## Inputs : $type - File type# $source - Source file - full path# Use local copy, not network copy for file ops# $target - Target file name# $md5sum - Precalculated MD5 sum## Returns :#sub addFile{my ($type, $source, $target, $md5sum) = @_;my %data;if ((not defined $md5sum) && ($type eq 'file')){Verbose("Calculate MD5 Digest: $source");open(my $fh , $source) or Error ("Can't open '$source': $!");binmode $fh, ':crlf';$md5sum = Digest::MD5->new->addfile($fh)->hexdigest;close $fh;}$target =~ s~\Q$DPKG_DIR\E~~;$target =~ s~^/~~;$target =~ s~/$~~;## Convert from iso-8859-1 into utf-8#$target = decode( 'iso-8859-1', $target );$target = encode( 'utf-8', $target );if ($type eq 'dir'){$data{path} = $target;}else{$data{path} = StripFileExt($target);$data{name} = StripDir($target);if ($type eq 'file'){$data{size} = (stat($source))[7];$data{md5sum} = $md5sum;}}$data{fullname} = $target;$data{type} = $type;$data{machtype} = $GBE_MACHTYPE;$data{host} = $GBE_HOSTNAME;# Put a nice '/' on the end of the path elements$data{path} .= '/'if ( exists ($data{path}) && length($data{path}) > 0);push @fileList, \%data;}#-------------------------------------------------------------------------------# Function : writeFileInfo## Description : Write out an XML file that contains this processes# contribution to the output package## Inputs : $targetDir - Base directory for the file## Returns :#sub writeFileInfo{my ($targetDir) = @_;my $data;$data->{file} = \@fileList;## Write out sections of XML# Want control over the output order# Use lots of attributes and only elements for arrays# Save as one attribute per line - for readability#$opt_outfile = $opt_generic ? "built.files.generic.xml" : "built.files.$GBE_HOSTNAME.xml";$opt_outfile = catfile( $targetDir, $opt_outfile);LogFileOp ('Meta File', $opt_outfile);my $xs = XML::Simple->new( NoAttr =>0, AttrIndent => 1 );open (my $XML, '>', $opt_outfile) || Error ("Cannot create output file: $opt_outfile", $!);$xs->XMLout($data,'RootName' => 'files','XMLDecl' => '<?xml version="1.0" encoding="UTF-8"?>','OutputFile' => $XML);close $XML;}#------------------------------------------------------------------------------sub Init## Description:# This function is used to process any command line arguements# and print the start banner.##------------------------------------------------------------------------------{# Process any command line arguements...my $result = GetOptions ('help:+' => \$opt_help, # flag, multiple use allowed'manual:3' => \$opt_help, # flag'verbose:+' => \$opt_verbose, # flag, multiple use allowed'override!' => \$opt_override, # [no]flag (No longer used. Backward compat with build tool)'delete!' => \$opt_delete, # [no]flag'merge|m!' => \$opt_merge, # [no]flag.'archive=s' => \$opt_archive, # string'quiet+' => \$opt_quiet, # Flag'generic!' => \$opt_generic, # [no]Flag'pname=s' => \$opt_pname, # string'pversion=s' => \$opt_pversion, # string'test!' => \$opt_test, # [no]flag'md5!' => \$opt_md5, # [no]flag'info!' => \$opt_info, # [no]flag'tarmode!' => \$opt_tarmode, # [no]flag'testArchive' => \$opt_testArchive, # [no]flag'nobuild' => \$opt_noBuild, # flag'keepTemp' => \$opt_keepTemp, # 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_help > 2);## Init the error and message subsystem#ErrorConfig( 'name' =>'CREATE_DPKG','verbose' => $opt_verbose,'quiet' => $opt_quiet );if ($opt_verbose){Verbose ("Program: $PROGNAME");Verbose ("Version: $VERSION");}## Needed EnvVars#EnvImport ('GBE_MACHTYPE');EnvImport ('GBE_HOSTNAME');EnvImport ('USER' );EnvImportOptional ('GBE_ABT', "");EnvImportOptional ('GBE_DPKG_ESCROW', "");$CWD_DIR = catdir($CWD_DIR);## Determine the target archive# The default archive is GBE_DPKG, but this may be changed#unless ( $opt_archive ){$opt_archive = 'main';$opt_archive = 'escrow' if ($::GBE_DPKG_ESCROW);}my $archive_tag = $Archive2Var{$opt_archive};Error("Unknown archive specified: $opt_archive")unless ( $archive_tag );$DPKG_ROOT = $ENV{$archive_tag} || '';Verbose ("Archive Variable: $archive_tag" );Verbose2 ("Archive Path: $DPKG_ROOT" );## Append testArchive path#$DPKG_ROOT = catdir ($DPKG_ROOT, '.dpkg_archive', 'test_dpkg') if $opt_testArchive;## Detect NoBuild marker# This will bypass most of the operation of this package#$opt_noBuild = 2 if -f 'noBuild.gbe';if ( $opt_noBuild){Verbose ("NoBuild Marker file found");$SRC_ROOT = '';$DPKG_NAME = 'pkg';$DESCPKG_FILE = 'descpkg';$PKG_BASE =$CWD_DIR;## Use provided name and version# Comparatbility only with ANT build system. Not needed by JATS#if ($opt_pname && $opt_pversion) {$DPKG_NAME = $opt_pname;$DPKG_VERSION = $opt_pversion;}return;}## Check for a "pkg" directory# This may be in:# 1) The deploy directory (DEPLOY) build/deploy/descpkg# 2) The build directory (ANT) build/pkg/descpkg# 3) The current directory (JATS) pkg/xxxx/descpkg#$PKG_BASE = "$CWD_DIR/build/deploy";Verbose2 ("Looking for descpkg: $PKG_BASE");if ( -f "$PKG_BASE/descpkg" ){## This is a deployment package.# Force the use of the GBE_DPLY#$opt_archive = 'deploy' unless ( $opt_archive );}else{$PKG_BASE = "$CWD_DIR/build/pkg";Verbose ("Looking for descpkg: $PKG_BASE");if ( ! -f "$PKG_BASE/descpkg" ){$PKG_BASE = "$CWD_DIR/pkg";Verbose ("Looking for descpkg: $PKG_BASE");my @descPkgs = glob ("$PKG_BASE/*/descpkg");Error("Failed to find a package to transfer. Looked in:","./build/deploy","./build/pkg","./pkg/*")unless( @descPkgs );Error("Multiple packages detected:", @descPkgs) if (scalar @descPkgs > 1);}}Verbose("Package directory: $PKG_BASE");Error("Repository location not specified: $archive_tag")unless $DPKG_ROOT;Error("Failed to find Repository: $DPKG_ROOT")unless ( -d $DPKG_ROOT );# Locate the package# Packages are located by looking for a file called descpkg within the# main package directory.## This installation process only handles one such file#$descPkgCount = 0;File::Find::find( \&pkgFind, $PKG_BASE);if ($descPkgCount > 1 ){Warning ("Package contains multiple ($descPkgCount) descpkg files");}}#-------------------------------------------------------------------------------# Function : CheckDescPkg## Description : Check the descpkg file## Inputs : Globals## Returns : Will not return on error#sub CheckDescPkg{## May not need a package description if performing a no-build# The package name and version will may be provided on the command line# Compatability for ANT builds##if ($opt_noBuild) {if ($opt_pname && $opt_pversion) {return;}Error("NoBuild operation requires package name and version")}# Get the dpkg_archive version number we are going to create.#Error("Descpkg file not found in package directory: $PKG_BASE")unless ( -f "$DESCPKG_FILE" );## Read in the package description and validate essential fields#GetDpkgArchiveVersion($DESCPKG_FILE);unless ( "$DPKG_VERSION" ){Error ("Incorrect descpkg content detected.","Check JATS build.pl config.");}## Need to support two forms of pkg subdirectory# 1) packages are in a named subdir within 'pkg'# 2) package is within 'pkg' or 'deploy'#if ( $DPKG_NAME eq 'pkg' || $DPKG_NAME eq 'deploy' ){$DPKG_NAME = $DESC_NAME;unless ( $DESC_NAME ){Error ("Cannot determine package name","The packages 'descpkg' file is bad or missing");}}elsif ( $DESC_NAME ne $DPKG_NAME ){Error ("Package name MUST match package description","Check build.pl and package.pl","Package name: $DPKG_NAME","Description : $DESC_NAME" );}## lets just check to see if we have a version number before# we proceed.#unless ( $DPKG_VERSION ){Error("Cannot determine dpkg_archive version number.","Check JATS build config.");}my ($pn, $pv, $ps ) = SplitPackage ($DPKG_NAME, $DPKG_VERSION );$DPKG_PRJ = '.' . $ps if ( $ps );## Sanity test package name and version, if provided#if ( $opt_pname ){ReportError ("Package Name does not match expected name","Expected: '$opt_pname'","Descpkg : '$DPKG_NAME'") unless ( $DPKG_NAME eq $opt_pname );}if ( $opt_pversion ){ReportError ("Package Version does not match expected version","Expected: '$opt_pversion'","Descpkg : '$DPKG_VERSION'") unless ( $DPKG_VERSION eq $opt_pversion );}ErrorDoExit();}#-------------------------------------------------------------------------------# Function : ShowInfo## Description : Show info to the user## Inputs :## Returns :#sub ShowInfo{## Set up the target directory path and name# It will be created later#if ($opt_tarmode){$DPKG_DIR = catdir($DPKG_ROOT, '.dpkg_archive', 'fragments');}else{$DPKG_DIR = catdir($DPKG_ROOT, $DPKG_NAME, $DPKG_VERSION );}## Information for the user#Information ("---------------------------------------------------------------");Information ("Dpkg archive creation tool...");Information ("Version: $VERSION");Information ("");Information ("Information:");Information ("Escrow Build") if ($opt_archive eq 'escrow');Information ("Working dir = [$CWD_DIR]");Information ("Package Root = [$SRC_ROOT]");Information ("Repository = [$DPKG_ROOT]");Information (" *Non Standard archive") unless ($opt_archive eq 'main' || $opt_archive eq 'escrow');Information ("Target dir = [$DPKG_DIR]");Information1("DPKG_NAME = [$DPKG_NAME]");Information1("DPKG_VERSION = [$DPKG_VERSION]");Information1("DPKG_PRJ = [$DPKG_PRJ]");Information1("GBE_MACHTYPE = [$GBE_MACHTYPE]");Information1("GBE_HOSTNAME = [$GBE_HOSTNAME]");Information1("GBE_ABT = [$GBE_ABT]");Information1("USER = [$USER]");Information ("") if ( $opt_merge || $opt_delete || $opt_info || $opt_tarmode || $opt_testArchive || $opt_noBuild);Information ("Opt:NoBuild = Enabled") if ( $opt_noBuild );Information ("Opt:TarMode = Enabled") if ( $opt_tarmode );Information ("Opt:Delete = Enabled") if ( $opt_delete );Information ("Opt:Merge = Enabled") if ( $opt_merge );Information ("Opt:testArchive = Enabled") if ( $opt_testArchive );Information ("Opt:TestMode = Enabled. No Package Transferred") if ( $opt_test );Information ("Opt:Info = Enabled. No Package Transferred") if ( $opt_info );Warning ("Sandbox Build = Yes") if ($ENV{GBE_DPKG_SBOX}) ;Information ("---------------------------------------------------------------");## If the environment variable GBE_DPKG_SBOX is defined then the package# is being built within a development sandbox. In such a sandbox the# version numbers of the packages are ignored. Publishing a package# from such an environment is certainly not reproducible - so don't allow# it to happen## Allow versions of 99.99.99 as these are known to be test versions#unless ( $opt_archive eq 'local' || $opt_archive eq 'sandbox' || $opt_testArchive || $::GBE_DPKG_ESCROW){if ( $ENV{GBE_DPKG_SBOX} ){unless ( $DPKG_VERSION =~ /^99.99.99/ ){Error("Cannot not publish a package that has been generated","within a Sandbox as the version of dependent packages","is not guaranteed.","Only version 99.99.99 is allowed");}}}}#------------------------------------------------------------------------------sub pkgFind## Description:# This subroutine is used to locate the FIRST descpkg file in# the local pkg dir.##------------------------------------------------------------------------------{my($item)= "$File::Find::name";my($file)= File::Basename::basename($item);# we get the absolute path from the find, but we only require# a relative path from the starting dir.# so our start dir.# we need to determine which file we are dealing withif ( ! -d $item && $file =~ /^descpkg$/ ){$descPkgCount++;## Only grab the first one#if ( $DESCPKG_FILE ){$item =~ s~\Q$PKG_BASE\E/~~;Verbose ("Multiple descpkg files:", $item );return;}$DESCPKG_FILE = $item;my($dir)= File::Basename::dirname($item);$DPKG_NAME = File::Basename::basename($dir);$SRC_ROOT = catdir($dir);}}#------------------------------------------------------------------------------sub GetDpkgArchiveVersion## Description:# This subroutine is used to determine the version of the dpkg_archive.# We assume that the version number is in the descpkg file.## Need to allow for two forms of descpkg. Some one decided that a Java# Manifest would be a good descpkg file - a long time after the rest of the# world had been using an existing file format.## Lines are tagged## Once the version number is determined we set the# global DPKG_VERSION variable.##------------------------------------------------------------------------------{my ($path) = @_;my $line;my $type;## Use a common routine to parse the package descriptor# There are several forms that may need to be processed#Verbose ("GetDpkgArchiveVersion from $path");my $pkg_data = ReadDescpkg( $path );Error("Failed to open file [$path].") unless $pkg_data;$DESC_NAME = $pkg_data->{'NAME'};$DPKG_VERSION = $pkg_data->{'VERSION_FULL'};}#-------------------------------------------------------------------------------# Function : TransferDescpkg## Description : Copy and process the descpkg file to the target## Inputs :## Returns :#sub TransferDescpkg{my $result = CopyDescpkg( @_ );Error("Transfer descpkg: $result") if ( $result );}#------------------------------------------------------------------------------sub CreateDpkgArchive## Description:# This subroutine is used to create the dpkg_archive in the $DPKG_ROOT# location## We use the global DPKG_ROOT, DPKG_DIR, DPKG_NAME, and DPKG_VERSION# to create the required directory structure.## If the dpkg_archive is new (ie not a new version) it is assumed the user# has access to create the top level dir for the new dpkg_archive.## The new dpkg_archive is created with the permission of the user# executing this script.## If an error ocurs during the dpkg_archive creation the script# will terminate.##------------------------------------------------------------------------------{## first we need to ensure we have the top level directory#if ( -d $DPKG_DIR ){Warning("Detected previous dpkg_archive [$DPKG_DIR]");Error ("Package already exists and Package merging not selected")unless ( $opt_delete || $opt_merge );## Target exists# Unless we are merging, we need to blow the entire tree away#unless ( $opt_merge ){LogFileOp("Remove Prev Pkg",$DPKG_DIR);rmtree($DPKG_DIR);## At this point the target directory 'should not' exist# but it may. Some packges (like JATS) have Unix links within# dpkg_archive filesystem. These cannot be deleted under windows## Not nice, but we live with it.#Warning ("Unable to delete previous instance of the package")if ( -d $DPKG_DIR );}}Information("");## Create the top level directory#mkpath($DPKG_DIR, 0, 0775);## Transfer source directory, unless this is a noBuild#if ( $SRC_ROOT ne '' ){# Process the files#if ( -d $SRC_ROOT ){File::Find::find( \&pkgFind2, $SRC_ROOT );if (@bad_symlinks){my $msg = "Bad Symlinks: " . scalar @bad_symlinks;$opt_test ? ReportError($msg, @bad_symlinks) : Warning($msg, @bad_symlinks);}if ( $bad_merge_count ){my $msg = "Merged files that differ: $bad_merge_count";$opt_md5 ? ReportError($msg) : Warning($msg);}ErrorDoExit();}else{Error("Failed to find dir [$SRC_ROOT]","Check JATS config.");}}## Transfer of data is complete# Mark the archive with the build machine to indicate which parts of# a multi-machine build have been performed#my $touchfile = createBuiltFile($DPKG_DIR);addFile('file', $touchfile, $touchfile);## If there is a .lnk file in the archive then remove it now that the# archive has been transferred. The .lnk files are created in 'local'# archives in order to simplify multi-package builds#my $link_file = "$DPKG_ROOT/$DPKG_NAME/$DPKG_VERSION.lnk";if ( -f $link_file ){LogFileOp("Removing Link",$link_file);unlink $link_file;}## Create the MD5 info file#writeFileInfo($DPKG_DIR);return 1;}#------------------------------------------------------------------------------sub pkgFind2## Description:# This subroutine is used to locate all associated pkg files in# the local pkg dir.## This routine is called for each file and directory within the package# Some files and directories are treated in a special manner# - Top level directory is ignored####------------------------------------------------------------------------------{my $item = $File::Find::name;my $base = File::Basename::basename($item);## Calculate the target directory name#my $target = $item;$target = $DPKG_DIR . substr ( $item, length ($SRC_ROOT) );if ( -d $item ){## Ignore the top level directory# It has already been created#returnif ( $item eq $SRC_ROOT );## Directories are handled differently# - Directories are created with nice permissions# - If the directory already exists then it is being merged.#if ( ! -d "$target" ){LogFileOp("Creating Dir", $target);mkpath("$target", 0, 0775);addFile('dir', $item , $target);}}else{## File copy# If merging then do not overwrite an existing file#unless ( $opt_merge && -f $target ){if ( $item =~ m~/descpkg$~ ){LogFileOp("Rewrite File",$target);TransferDescpkg( $item, $target );CORE::chmod oct("0664"), $target;addFile('file', $item, $target);}else{## Copy file to destination# If the file is a link, then duplicate the link contents# Use: Unix libraries are created as two files:# lib.xxxx.so -> libxxxx.so.vv.vv.vv#if ( -l $item ){my $niceBase = substr ( $item, 1+length ($SRC_ROOT) );if (TestSymlink( $niceBase,$_)){# Don't copy broken Symlinks# Perhaps this should be an error - but is will break escrow builds#LogFileOp("Bad SymLink", $target);}elsif (-f $item){LogFileOp("Copying Link", $target);my $link = readlink $item;Verbose( "Link: $item, $link");symlink ($link, $target );unless ( $link && -l $target ){Error("Failed to copy link [$item] to [$target]: $!");}addFile('link', $item , $target);}}elsif (File::Copy::copy($item, $target)){LogFileOp("Copying File",$target);## Mark the file as executable by all# Under windows, this is tricky#if ( $Win32 ){my %hash;$hash{Everyone} = Win32::FileSecurity::MakeMask( qw( FULL ) );Win32::FileSecurity::Set( $target, \%hash );}else{CORE::chmod oct("0775"), $target;}addFile('file', $item, $target);}else{Error("Failed to copy file [$item] to [$target]: $!");}}}else{## Merging packages# Ensure that the descpkg file is "touched" so that caches# that use this file as a timestamp can be updated#if ( $item =~ m~/descpkg$~ ){LogFileOp("Touch File",$target);TouchFile( $target ) && Error ( "Failed to touch: $target" );addFile('merge', $item, $target);}else{## MD5 digest the files that are being merged# Ignore version_*.h files as these are generated# and may contain different dates and line endings## Don't put the files into 'binmode'# Need to handle some level of Unix/DOS file endings##my $msg = "Merge Skip File";unless ( $target =~ m~/version[^/]*\.h$~ ){$msg = "Merge Test File";## Compare the two files with an MD5#local *FILE;open(FILE, $target) or Error ("Can't open '$target': $!");binmode FILE, ':crlf';my $target_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;close FILE;open(FILE, $item) or Error ("Can't open '$item': $!");binmode FILE, ':crlf';my $source_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;close FILE;unless ( $source_md5 eq $target_md5 ){$msg = "DIFF: Merge Test File";$bad_merge_count ++;}addFile('merge', $item, $target, $target_md5);}LogFileOp($msg,$target);}}}}#-------------------------------------------------------------------------------# Function : CreateDpkgArchiveTarBall## Description : Similar to CreateDpkgArchive, but it will create a tar file within the target# directory.## This is used by the build system to:# 1) Greatly speedup the transfer of packages with a very large number of files# 2) Remove the need for an multi-filesytem, multi OS atomic lock on the package## The build system will process the tarball and create the package archive# In doing so it will handle merge errors## Inputs :## Returns :#sub CreateDpkgArchiveTarBall{Information("");InitFileUtils();## If a 'noBuild' then create a dummy package directory simply# to contain the metadata.# Delete any existing dir of the same name to ensure its clean.#if ( $SRC_ROOT eq '' ){$SRC_ROOT = catdir(AbsPath('pkg/noBuild'));RmDirTree ($SRC_ROOT);mkpath($SRC_ROOT, 0, 0775);}## Mark the archive with the build machine to indicate which parts of# a multi-machine build have been performed#createBuiltFile($SRC_ROOT);# Process the source directory# A NoBuild will contain one metafile#if ( -d $SRC_ROOT ){File::Find::find( \&pkgFindTarBall, $SRC_ROOT );if (@bad_symlinks){my $msg = "Bad Symlinks: " . scalar @bad_symlinks;$opt_test ? ReportError($msg, @bad_symlinks) : Warning($msg, @bad_symlinks);}ErrorDoExit();}else{Error("Failed to find dir [$SRC_ROOT]","Check JATS config.");}## Create the MD5 info file# Mark it as a temp file as it not being created locally#writeFileInfo($SRC_ROOT);push @tmpFiles, $opt_outfile;## Create the target path in the target archive#LogFileOp ('Creating', $DPKG_DIR);mkpath($DPKG_DIR, 0, 0775);## Create a tar.gz file an transfer to the final location## Have failed to find a nice windows utility to create a tar.gz# bsdtar - crashed under server 2003# cygwin - design decision. JATS will not include cygwin#my $tarTarget = join('_', $DPKG_NAME, $DPKG_VERSION, $GBE_HOSTNAME) . '.tar.gz';my $tarPath = catfile($DPKG_DIR, $tarTarget);$FileUtils::isUnix ? createUnixTar($tarPath) : createWindowsTar($tarPath);}#-------------------------------------------------------------------------------# Function : createUnixTar## Description : Create a tar.gz file under unix## Inputs : $tarPath - Place tarfile here# $SRC_ROOT - Directory to tar## Returns : Will not return on error#sub createUnixTar{my ($tarPath) = @_;## Locate the tar utility# Use gtar if its available otherwise use tar#my $tarProg = LocateProgInPath('gtar', '--All');$tarProg = LocateProgInPath('tar', '--All') unless $tarProg;Error ("Tar utility not found in path") unless $tarProg;## Tar and gzip file directly into the final locationLogFileOp ('TarZip', $tarPath);my @tarArgs;push @tarArgs, '-v' if IsVerbose(1);my $rv = System ('--NoShell', '--NoExit',$tarProg, @tarArgs, '-czf', $tarPath, '-C', $SRC_ROOT, '.' );if ($rv){push @tmpFiles, $tarPath;Error ('Cannot create tarball', "Path:$tarPath");}}#-------------------------------------------------------------------------------# Function : createWindowsTar## Description : Create a tar.gz file under Windows# Use 7zip (part of JATS)# 7zip cannot do this in one step# Create tar file# Create zip file## Inputs : $tarPath - Place tarfile here# $SRC_ROOT - Directory to tar## Returns : Will not return on error#sub createWindowsTar{my ($tarPath) = @_;my @verboseArgs = qw(-bb1);my $verboseCopyArg = '9';## Ensure that the target file does not exist# 7z cannot ovewrite it#LogFileOp ('Delete', $tarPath);RmDirTree($tarPath) && Error ("Target file cannot be deleted", "Target: $tarPath");## Setup NON-verbose arguments for 7zip#unless (IsVerbose(1)) {@verboseArgs = qw(-bb0 -bso0 -bsp0);$verboseCopyArg = '0';}## Create a tar file of the required output# Create the tar file into a temp file that will be deleted on exit#my $tmpTarFile = catfile($CWD_DIR, join('_', $DPKG_NAME, $DPKG_VERSION) . '.tar' );Verbose("TempTar: $tmpTarFile");RmDirTree($tmpTarFile) && Error ("Target file cannot be deleted", "Target: $tmpTarFile");push @tmpFiles, $tmpTarFile;LogFileOp ('TempTar', $tmpTarFile);chdir ($SRC_ROOT) || Error ("Cannot change directory: $?", "Dir: $SRC_ROOT");my $rv = System ('--NoShell', '--NoExit','7z.exe', 'a', '-r','-y', @verboseArgs, '-ttar', $tmpTarFile, '.' );if ($rv){Error ('Cannot create tar file');}chdir ($CWD_DIR) || Error ("Cannot change directory: $?", "Dir: $CWD_DIR");## gzip the tar file to a temp (local) location#my $tmpTarGzFile = catfile($CWD_DIR, join('_', $DPKG_NAME, $DPKG_VERSION) . '.tar.gz' );Verbose("TempTarGz: $tmpTarGzFile");RmDirTree($tmpTarGzFile) && Error ("Target file cannot be deleted", "Target: $tmpTarFile");push @tmpFiles, $tmpTarGzFile;LogFileOp ('TempTarGz', $tmpTarGzFile);$rv = System ('--NoShell', '--NoExit','7z.exe', 'a', '-y', @verboseArgs, '-tgzip', $tmpTarGzFile, $tmpTarFile );if ($rv){Error ('Cannot gzip tar file');}## Copy the file to the target# Note: Jats internal copy# Args are strange as it was designed to work with makefile stuff#LogFileOp ('CopyTarZip', $tarPath);$rv = System ('--NoShell', '--NoExit','JatsFileUtil.exe', 'c' . $verboseCopyArg, 'copyFile', $tarPath, $tmpTarGzFile, '+w' );if ($rv){push @tmpFiles, $tarPath;Error ('Cannot transfer tarball', "Path:$tarPath");}}#-------------------------------------------------------------------------------# Function : pkgFindTarBall## Description : Used by CreateDpkgArchiveTarBall# File::Find processing function## This routine is called for each file and directory within the package## Inputs : As per File::Find## Returns : Nothing#sub pkgFindTarBall{my $item = $File::Find::name;my $base = File::Basename::basename($item);my $type;## Ignore the top level directory#return if ( $item eq $SRC_ROOT );## Determine type of this item# file# link, badlink# dirif ( -l $item){my $niceBase = substr ( $item, 1+length ($SRC_ROOT) );if (TestSymlink( $niceBase,$_)) {## Broken/Bad symlink# Remove it from the 'pkg'# Could try other ways of excluding it from the tar, but this is the simplestLogFileOp("Bad SymLink", $item);$type = 'badlink';unlink $item;return;} else {$type = 'link';}} elsif ( -f $item) {$type = 'file';} elsif ( -d $item) {$type = 'dir';} else {Error("Unknown file type. Cannot be packaged");}## Calculate the target directory name#my $target = $item;$target = $DPKG_DIR . substr ( $item, length ($SRC_ROOT) );addFile($type, $item, $target);LogFileOp('Process',$item);}#-------------------------------------------------------------------------------# Function : TestDpkgArchive## Description : Test the structure of the source achive# Ensure that it has some files# Warn if files are present in the root directory## Inputs : None## Returns : Warnings#my $test_dir_count = 0;my $test_file_count = 0;my @test_root_file = ();sub TestDpkgArchive{$test_dir_count = 0;$test_file_count = 0;@test_root_file = ();if ( $SRC_ROOT ne '' ){Error("Failed to find dir [$SRC_ROOT]","Check JATS config.") unless ( -d $SRC_ROOT );## Scan the package counting files and folders#File::Find::find( \&pkgFind3, $SRC_ROOT );}Information ("Package contains:","Files: $test_file_count","Dirs: $test_dir_count",);## There shouldn't be any files in the root directory# other than the descpkg and incpkg.#Warning ("Unexpected files in package root:", @test_root_file)if ( @test_root_file );Error ("Bad symbolic links found:", @bad_symlinks)if ( @bad_symlinks );}sub pkgFind3{## Calculate the target directory name#my $target = $File::Find::dir;$target = substr ( $target, length ($SRC_ROOT) );$target =~ s~^.~~;if ( -d $_ ) {$test_dir_count++;} else {$test_file_count++;unless ( $target ){## Locate files in the package root directory that# are not expected to be there.#unless (( $_ eq 'descpkg' ) || ( $_ eq 'incpkg' ) || $_ =~ m~built\.*~){push @test_root_file, $_;}}TestSymlink($target, $_);}}#-------------------------------------------------------------------------------# Function : TestSymlink## Description : Test a symlink for validity# Current drectory will be $dir## Inputs : $dir# $fname## Returns : True if a bad symlink# Add error messages to @bad_symlinks#sub TestSymlink{my ($dir, $fname) = @_;my $msg;my $rv = 0;my $file = join ('/', $dir, $fname) ;#Debug0("Testing: $file");if (-l $fname) {my $link = readlink $fname;if ($link =~ m~^/~) {$msg = '[Absolute link not allowed]:' . $file . ' -> ' . $link;# Need to test if the symlink escapes the package# } elsif ($link =~ m~/~) {# push @bad_symlinks, '[Symlink out of directory]:' . $file . ' -> ' . $link;} elsif (! -f $fname) {$msg = '[Broken Link]:' . $file . ' -> ' . $link;} else {my @cleanParts = split ('/', CleanPath($link));my @dirParts = split('/', $dir);my $upCount = 0;foreach ( @cleanParts ) {if ($_ eq '..') {$upCount++;} else {last;}}if ($upCount > scalar @dirParts) {$msg = '[Escapes Package]:' . $file . ' -> ' . $link;}}}if ($msg) {push @bad_symlinks, $msg;$rv = 1;}return $rv;}#-------------------------------------------------------------------------------# Function : createBuiltFile## Description : Create the packages built.xxxx file# Used to track which build machines have contributed to the build## Inputs : $targetDir - Base directory for the file## Returns : Full pathname of the generatde file#sub createBuiltFile{my ($targetDir) = @_;## Mark the archive with the build machine to indicate which parts of# a multi-machine build have been performed#my $touchfile = catfile( $targetDir, $opt_generic ? 'built.generic' : "built.$GBE_HOSTNAME");## Create a string to be appended to the 'built' file# Comma seperated list of (possibly) useful info# Date-Time ( Local and GMT)# machine type, machine name and the user# GBE_ABT value## Having build issues where the file is not seen for a very long time#my $built_info = localtime() ."," . gmtime() . " GMT,$GBE_MACHTYPE,$GBE_HOSTNAME,$USER,$GBE_ABT";LogFileOp("Mark File",$touchfile);FileAppend ( $touchfile, $built_info );return $touchfile;}#-------------------------------------------------------------------------------# Function : END Block## Description : Post execution cleanup## Inputs :## Returns :#END{## Save the programs exit code# This END block may use the 'system' call and this will clobber the value in $?# which is the systems exit code#Verbose2("Cleanup processing");local $?;## Delete temp files#foreach my $tmpFile ( @tmpFiles){if ($opt_keepTemp){Information("Retain Temp file: " . $tmpFile);}else{Verbose ("Delete file: " . $tmpFile);RmDirTree ($tmpFile) && Warning("$tmpFile not deleted");}}}# ---------------------------------------------------------# ---------------------------------------------------------# Main# ---------------------------------------------------------# ---------------------------------------------------------# Initialise our world#Init();CheckDescPkg();ShowInfo();unless ($opt_info){unless ( $opt_test ){if ($opt_tarmode){LogFileOp("Creating dpkg_archive tarball:", $DPKG_DIR);CreateDpkgArchiveTarBall();}else{LogFileOp("Creating dpkg_archive package:", $DPKG_DIR);CreateDpkgArchive();}}else{Information("Testing user package.");TestDpkgArchive();}}# Done#Information ("Done.");exit 0;#-------------------------------------------------------------------------------# Documentation#=pod=for htmltoc SYSUTIL::=head1 NAMEcreate_dpkg - Create a dpkg_archive entry=head1 SYNOPSISjats create_dpkg [options]Options:-help - Brief help message-help -help - Detailed help message-man - Full documentation-quiet - Suppress progress messages, then warning messages-verbose - Display additional progress messages-override - Deprecated option-delete - Delete any previous version of the package-[no]merge - merge with existing version of the package-archive=name - Specify archive (cache, local, main, store, sandbox, deploy, escrow)-pname=name - Ensure package is named correctly-pversion=version - Ensure package version is correct-generic - Create a built.generic file-noBuild - Create dummy build files-[no]tarmode - Transfer package as tarball-[no]md5 - Use MD5 comparison of merged files(enabled)Debug and Testing:-[no]test - Test package. Do not transfer.-[no]info - Display packaging info. Do not transfer.-[no]testArchive - Perform operations within a test archive-keepTemp - Do not delete temp files=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>This option will suppress almost all of the progress messages, except for a singlecopy message. It is intended to be used when the program is called from anotherscript.=item B<-override>If this option has been deprecated. It has no effect.It is still present to preserve backward compatability with the automatedbuild system.=item B<-delete>If this option is enabled then any previous version of the target package willbe deleted.=item B<-merge>If this option is enabled then the package will be merged with any existingpackage. This option is used by the auto build tool to assemble multi-machinepackages in dpkg_archive.=item B<-archive=name>This option specifies the destination archive to be used. The following namesare supported:=over 8=item cacheThe location of the target archive will be taken from C<GBE_DPKG_CACHE>.=item localThe location of the target archive will be taken from C<GBE_DPKG_LOCAL>.=item main (default)The location of the target archive will be taken from C<GBE_DPKG>. This is thedefault target archive.=item storeThe location of the target archive will be taken from C<GBE_DPKG_STORE>.=item replicaThe location of the target archive will be taken from C<GBE_DPKG_REPLICA>.=item sandboxThe location of the target archive will be taken from C<GBE_DPKG_SBOX>.=item deployThe location of the target archive will be taken from C<GBE_DPLY>.Note: This archive is no longer fully supported.=item escrowThe location of the target archive will be taken from C<GBE_DPKG_ESCROW>.This is the default target archive if an escrow build is detected.=back=item B<-pname=name>If this option is provided, the utility will ensure that the package is namedcorrectly.=item B<-pversion=version>If this option is provided, the utility will ensure that the package version isthat expected.=item B<-generic>This option will create a built.generic file, instead of one based on the machinethat actually built the package. This is used by the AutoBuilder toolchain.=item B<-noBuild>This option is only used by the build daemons. It is used to create all requiredfiles to indicate that the build has occured correctly. It will only be used by ANTbased builds as true JATS builds handle this situation internally.=item B<-[no]tarmode>This option will cause the package to be transferred into the package archive asa tar ball. Used in the build system to address two issues:=over 4=item 1Slow speed in copying lots of files from the build machine to the package server.=item 2Need for cross platform file lock in order to prevent copy collisions.=back=item B<-[no]md5>If package builds are being merged then a validity check is performed usingan MD5 digest over the current and the existing file.By default, it is an error for the user file to differ from the merged file.This option disabled the error. The test is still done and the results arereported.=item B<-test>If this option is enabled the utility will perform initial sanity testing, butit will not perform the copy.=item B<-[no]info>This option will cause the program to display information about the packagingprocess and then exit.No data will be transferred to the archive.=item B<-[no]testArchive>If this option is enabled then the assembly operation is performed within a test area withinthe currently configured dpkg_archive. The test area is a subdirectorycalled C<.dpkg_archive/test_dpkg>This option is intended for testing use only.=item B<-keepTemp>This option will prevent temp files, created by this utilty, from being deleted when the utiltyexists.This option is intended for testing use only.=back=head1 DESCRIPTIONThis utility program is used to transfer a package that has been built intodpkg_archive. The package is then available for general consumption.The utility will perform several operations in the transfer process. These incude:=over 4=item *Create a tag file to indicate the machine that has performed the transfer=item *Create an XML file of files that have been transferred. This file contains informationused by the build system when it releases the package, including: name, size and MD5SUM.=item *Detect file conflicts when different builds are merged into a single package. Header files areallowed to differ in line ending style, but other files must not conflict. The package will not bereproducible if file conflicts exist.In 'tarmode' the package merging needs to be done by another utility.=item *Suppress dead symbolic links. A valid symlink will be preserved, but invalid links will beremoved from the transferred image.=back=head2 PACKAGE LOCATIONThe utility will locate a package by examining the following directores forthe package description file(descpkg).=over 8=item ./build/deployThis format is generated by the deployment builds. The default target archivewill be taken from the environment variable GBE_DPLY.=item ./pkgThis format is generated by JATS builds.=item ./build/pkgThis format is generated by ANT builds.=item ./pkg/noBuildThis format is used internally by this utilty. It will be generated by the build systemin cases where there is no build to be performs on the current machine.=backThe program should be run in the same directory as the build control files asthe package subdirectory will be created in that directory.=head1 EXAMPLE=head2 jats create_dpkgThis will locate a generated package and install it into the dpkg_archive repository.=cut