######################################################################## # Copyright (C) 2006 ERG Limited, All rights reserved # # Program Name : deploylib.pm # # Program Type : Perl Module (.pm) # # Original Author(s) : V.Chatzimichail(vasilic) # # Description / Purpose: # Deploylib is a set of high-level functions written in Perl (for portability) # that allow a user to quickly setup a deployment configuration and produce a # deliverable package. # # Description: # # # # 2008-08-13 Note on --InstallProdAndDebug option and AlternateBuildType: # This option has been added to several functions to allow for the a build # to contain both debug and production files. # Most of the deploylib is based on the use of $BuildType to determine where # to look for things and what files to include. To allow for both types, # $AlternateBuildType is set up to hold the opposite of $BuildType # (e.g. D vs P). and the DpkgBinDirListAlternate and DpkgLibDirListAlternate # variables are set up to hold 'alternate' sets of directories to search. # In theory, we should support 'any' build type, in which case this option # would be implemented differently, but P/D are hardcoded throughout here, # so this was done as a minimal impact change. # # #......................................................................# require 5.006_001; #------------------------------------------------------------------------------ # Package definition #------------------------------------------------------------------------------ package deploylib; #------------------------------------------------------------------------------ # Pragmas #------------------------------------------------------------------------------ use strict; use Getopt::Std; use File::Copy; use File::Find; use File::Basename; use File::Path; use Cwd; use Carp; use DBI; use DeployUtils::RmPkgInfo; use BuildConfig; use Exporter(); use ArrayHashUtils; use JatsEnv; use JatsError; use JatsSystem; #------------------------------------------------------------------------------- # Export variables and function into the users name space #------------------------------------------------------------------------------- our @ISA = qw(Exporter); our @EXPORT = qw( &Init &setPkgDescription &setPkgName &setErgAfcBaseDir &setPkgOverview &addInstallshieldFiles &installAllDpkgArchivePkgFiles &installAllDpkgArchivePkgFiles2 &installAllDpkgArchiveDevcdFiles &installAllDpkgArchiveJspFiles &installAllDpkgArchiveFiles &installAllDpkgArchiveAcHtmlFiles &installAllDpkgArchiveInfoFilesFiles &installAllDpkgArchiveSqlFiles &installAllDpkgArchiveWarFiles &installAllDpkgArchiveJarFiles &installAllDpkgArchiveEtcFiles &installAllDpkgArchiveScriptsFiles &installAllDpkgArchiveIncludeFiles &installAllDpkgArchiveDocFiles &installDpkgArchiveFile &installDpkgArchiveAcHtmlFile &installDpkgArchiveRptFile &installDpkgArchiveRoxFile &installDpkgArchiveDatFile &installDpkgArchiveThxFile &installDpkgArchiveMugFile &installDpkgArchiveInfoFilesFile &installDpkgArchiveSqlFile &installDpkgArchiveWarFile &installDpkgArchiveJarFile &installDpkgArchiveSarFile &installDpkgArchiveEtcFile &installDpkgArchiveScriptsFile &installDpkgArchiveIncludeFile &installDpkgArchiveDocFile &installDpkgArchiveBinFile &installDpkgArchiveLibFile &installPkgAddConfigFile &installPkgAddSystemClassFile &installDpkgArchivePkgRaw &updatePrototypeFileAddItem &updatePrototypeFileAddItem2 &addPath2Prototype &createAfcRcScriptLink &createAfcRcScriptLink2 &installAllDpkgArchiveBinFiles &CreateTargetDirStructure &createPatch &createPackage &createPrototypeFile &addPatchInfo2ProtoTypeFile &addPkgInfoClasses &addPkgInfoField &updatePrototypeFileItemClass &useReplaceClass &setReplaceClassFiles &createPkginfoFile &updatePrototypeFileItemOwner &setPermissions &chmod &chmodRecursive &chmodDir &chmodFile &createSymbolicLink &createPrototypeFile2 &installDeployFile &createDpkgArchive &generateHtmlReleaseNote &generateIShieldIncludeFile &createPerlSvcWin32 &createPerlAppWin32 &convertFile &getErgAfcBaseDir &getGenericNameNoVersionForLib &getGenericNameForLib &createZip &generateXmlDependancy %TargetDstDirStructure %LocalSrcDirStructure %BuildPkgArchive $MachType $TargetHomeDir $TargetBaseDir $PkgName $PkgVersionUser $PkgVersion ); #------------------------------------------------------------------------------ # Constants global/local to this package #------------------------------------------------------------------------------ use vars qw ( $opt_n $opt_v $opt_r $opt_t $opt_m $opt_d $opt_p $opt_o $opt_k $opt_g ); my ($VENDOR_DESC) = "ERG Transit Systems Ltd"; my ($CATEGORY_DESC) = "application"; my ($ERGAFC_BASEDIR) = "/afc"; my ($MAXINST) = "1000"; my ($PKG_OVERVIEW) = "To Be Defined."; my (@PATCH_INFO_FILES) = qw ( checkinstall copyright patch_checkinstall patch_postinstall i.none postinstall preinstall ) ; my (@PATCH_UTIL_FILES) = qw ( backoutpatch installpatch ); my (@PKG_UTIL_FILES) = qw ( requestlib.sh chkuser.pl ); my (@PKG_ISHIELD_FILES) = qw ( ishieldlib.rul ishieldlib.h ); my (@PKG_ISHIELD_IMG_FILES) = qw ( islib_pane.bmp islib_splash.bmp islib_topicon.bmp ); my (@PATCH_ISHIELD_FILES) = qw ( postinstall.rul preinstall.rul postremove.rul preremove.rul ); my ($ISHIELD_PKGDEF_FILE) = "pkgdef.h"; my ($ISHIELD_PROJECTDIR) = ""; my ($ISHIELD_PROJECT) = ""; my ($ISHIELD_ROOT); my ($PKG_UTIL_DIR) = ""; my ($PATCH_UTIL_DIR) = ""; my ($m_UID) = ""; my ($m_GID) = ""; my ($m_MASK) = ""; my ($m_KEEP_MASK) = ""; my ($m_KEEP_LINKS) = ""; #------------------------------------------------------------------------------ # Variables global/local to this package #------------------------------------------------------------------------------ our $InterfaceDir = ""; our $DpkgBinDir = ""; our %DpkgBinDirList = (); our %DpkgBinDirListAlternate = (); # bin dir list for $AlternateBuildType our $DpkgLibDir = ""; our %DpkgLibDirList = (); our %DpkgLibDirListAlternate = (); # lib dir list for $AlternateBuildType our $DpkgScriptsDir = ""; our $DpkgEtcDir = ""; our $DpkgJarDir = ""; our $DpkgSarDir = ""; our $DpkgWarDir = ""; our $DpkgSqlDir = ""; our $DpkgInfoFilesDir = ""; our $DpkgPkgDir = ""; our $DpkgJspDir = ""; our $DpkgRoxDir = ""; our $DpkgRptDir = ""; our $DpkgAcHtmlDir = ""; our $DpkgIncludeDir = ""; our $DpkgDevcdDir = ""; our $DpkgDatDir = ""; our $DpkgThxDir = ""; our $DpkgMugDir = ""; our $DpkgDocDir = ""; our @LibCheckList = (); our $CurrentDir = ""; our $RootDir = ""; our $BuildType = ""; our $AlternateBuildType = ""; # the opposite of $BuildType our $MachType = ""; our $MachArch = ""; our $MachISA = ""; our $Platform = ""; our $Product = ""; our $Target = ""; our $SrcDir = ""; our $PkgDir = ""; our $ReleaseDir = ""; our $Username = ""; our $PkgBaseDir = ""; our $PkgInfoFileName = "pkginfo"; our $PkgInfoFile = ""; our $ProtoTypeFileName = "prototype"; our $ProtoTypeFile = ""; our $PkgPatchName = ""; our $PkgPatchID = ""; our $PkgPatchNum = ""; our $PkgPatchReadme = ""; our $PkgPatchTmpDir = ""; our $PkgVersion = ""; our $PkgVersionStr = ""; our $PkgVersionUser = ""; our $PkgName = ""; our $PkgBuildNum = ""; our $PkgOutputFile = ""; our $PkgReleaseNote = ""; our $PkgLabel = ""; our $PkgDesc = ""; our $PkgNameLong = ""; our $PkgInfoClasses = "none"; our $PkgPreviousVersionStr = ""; our $TargetBaseDir = ""; our $TargetHomeDir = ""; our $ProjectAcronym = ""; our $TmpGlobalVariable = ""; # used to pass variables into PERL find functions our %TargetDstDirStructure = (); our %LocalSrcDirStructure = (); our $BuildFileInfo = ""; # This was removed to add the use of the Buildfile.pm module, but this hash is needed # because the deployfiles use it for library version numbers in the file lists. # So it is left here and is a simply copy of the hash from buildfile pm our %BuildPkgArchive = (); our $RmPkgDetails = undef; our $RmPvPkgDetails = undef; #------------------------------------------------------------------------------ # Initialization actions #------------------------------------------------------------------------------ # # Init the error and message subsystem # ErrorConfig( 'name' => 'DEPLOYLIB' , 'debug' => $ENV{GBE_DEBUG}, 'verbose' => $ENV{GBE_VERBOSE}, ); #------------------------------------------------------------------------------ # Package Interface Subroutines # # The following functions are used by the Makefile.pl scripts. Programmers # call the following functions to set up the basic requirements that the # automated make system requires. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ sub Init # # Description: # Tests Environment Variables, it also checks the required command line # variables. # # Inputs: # Command line. # # Returns: # 1 # # Globals: # $makelib::RootDir # # Notes: # - # # Todo: # - #------------------------------------------------------------------------------ { # first we deal with the command line values we expect, these include: # GBE_ROOT (-r) # Package Name (-n) # Package Home Directory (relative to the ERGAFC_BASEDIR) (-d) # Package Version (-v) # Build Type (-t) # Patch Number (-p) # Previous (old) version number (-o) # Platform (-m) # Product (optional) (-k) # Machine Type (optional) (-g) $CurrentDir = cwd; my ($i); Getopt::Std::getopts ('v:n:r:t:m:d:p:o:k:g:'); if ( $opt_n ) { $PkgName = $opt_n; } else { Error("Package Name not supplied!"); } if ( $opt_r ) { # lets change to root dir and get fully qualified path from cwd and return back chdir($opt_r); $RootDir = cwd; chdir($CurrentDir); } else { Error("GBE_ROOT not supplied!"); } if ( $opt_t ) { $BuildType = $opt_t; } else { Error("GBE_TYPE not supplied!"); } # # Target machine type ( Underlying machine type in a Product Family) # If not provided, the assume that its the same as the platform (compat) # $opt_g = $opt_m unless ( $opt_g ); if ( $opt_g ) { $Target = $opt_g; if ( $Target =~ /^SOLARIS/ ) { $MachType = 'sparc'; if ( $Target =~ /X86/i ) { $MachArch = 'i386'; $MachISA = ""; } elsif ( $Target =~ /X64/i ) { $MachArch = 'i386'; $MachISA = "amd64"; } elsif ( $Target =~ /SPARC64/i ) { $MachArch = 'sparc'; $MachISA = "sparcv9"; } else { $MachArch = 'sparc'; $MachISA = ""; } } elsif ( $Target =~ /^WCE/ ) { $MachType = 'WinCE'; } elsif ( $Target =~ /^WIN32/ ) { $MachType = 'win32'; } else { Error("Unknown target [$opt_g] supplied!"); } } # # Platform # This is the full product name in a product family. # if ( $opt_m ) { $Platform = $opt_m; } else { Error("Platform not supplied!"); } # # Setup Product # If not defined then use the platform # $Product = $opt_k ? $opt_k : $Platform; if ( $opt_d ) { # if no targetbasedir then set it to "." to simulate targetbasedir if ( $opt_d eq "--NoDir" || $opt_d eq "--NoTargetBaseDir" ) { $TargetBaseDir = "."; } else { $TargetBaseDir = $opt_d; } } else { Error("Package base directory not supplied!"); } if ( $opt_p ) { my $pNum = sprintf("%02s", $opt_p); if ( "$pNum" =~ m/^[0-9][0-9]$/ ) { $PkgPatchNum = $pNum; } else { Error("-p command line arg [$opt_p] has invalid format", "Required format is an integer value."); } } if ($opt_v) { if( "$opt_v" =~ m/^(\d*)\.(\d*)\.(\d*)-(\d*)\.([a-z]{2,4})$/ ) # N.N.N-N.pppp { my ($s1, $s2, $s3, $s4, $s5) = ($1, $2, $3, $4, $5); $PkgVersionStr = sprintf("%02s%02s%02s", $s1,$s2,$s3); $PkgVersion = "$s1\.$s2\.$s3"; $PkgBuildNum = $s4; $ProjectAcronym = $s5; } elsif( "$opt_v" =~ m/^(\d*)\.(\d*)\.(\d*)\.([a-z]{2,4})$/ ) # N.N.N.pppp { my ($s1, $s2, $s3, $s4) = ($1, $2, $3, $4); $PkgVersionStr = sprintf("%02s%02s%02s", $s1,$s2,$s3); $PkgVersion = "$s1\.$s2\.$s3"; $PkgBuildNum = "1"; $ProjectAcronym = $s4; } else { Error("-v command line arg [$opt_v] has invalid format", "Allowed formats are N.N.N-B.ppp and N.N.N.ppp where:", " N is an integer", " B is an integer", " ppp is the project acronym (2..4 characters)", "Check propject acronym."); } $PkgVersionUser = $opt_v; } else { Error("Package Version not supplied!"); } # lets check to see if we have a previous version if ($opt_o) { $PkgPreviousVersionStr = $opt_o; } # Load the JATS-parsed information from the build.pl file # $BuildFileInfo = DeployUtils::BuildConfig->new($RootDir, $Platform); # Load all our build dependencies # %BuildPkgArchive = $BuildFileInfo->getDpkgArchiveHash(); # TargetHomeDir should not really be used for anything # $TargetHomeDir = ($TargetBaseDir ne ".") ? "$ERGAFC_BASEDIR/$TargetBaseDir" : "$ERGAFC_BASEDIR"; $TargetHomeDir =~ s|/{2,}|/|g; # # Determine InstallShield project location # Neeed to setup $PkgDir correctly # detectInstallShieldProject(); $PkgDir = ($ISHIELD_ROOT ? $ISHIELD_ROOT : $RootDir) . '/pkg'; $SrcDir = "$RootDir/src"; $InterfaceDir = "$RootDir/interface"; $ReleaseDir = "$RootDir/build/deploy"; $PKG_UTIL_DIR = "$InterfaceDir/deployfiles"; $PATCH_UTIL_DIR = $PKG_UTIL_DIR; # # InstallShield files are provided via a package # Ensure that a suitable package has been provided # if ( ! -d $PKG_UTIL_DIR ) { Error("No deployment support files found", "These MUST be provided by a dependant package in build.pl"); } $Username = getlogin || getpwuid($<); if ( "$BuildType" eq "D" ) { $PkgBaseDir = "$PkgDir/debug"; $AlternateBuildType = "P"; } else { $PkgBaseDir = "$PkgDir/prod"; $AlternateBuildType = "D"; } $PkgInfoFile = "$PkgBaseDir/$PkgInfoFileName"; $ProtoTypeFile = "$PkgBaseDir/$ProtoTypeFileName"; $DpkgScriptsDir = "$InterfaceDir/scripts"; $DpkgEtcDir = "$InterfaceDir/etc"; $DpkgJarDir = "$InterfaceDir/jar"; $DpkgSarDir = "$InterfaceDir/sar"; $DpkgWarDir = "$InterfaceDir/war"; $DpkgSqlDir = "$InterfaceDir/sql"; $DpkgInfoFilesDir = "$InterfaceDir/infofiles"; $DpkgPkgDir = "$InterfaceDir/pkg"; $DpkgJspDir = "$InterfaceDir/jsp"; $DpkgRoxDir = "$InterfaceDir/rox"; $DpkgRptDir = "$InterfaceDir/rpt"; $DpkgAcHtmlDir = "$InterfaceDir/achtml"; $DpkgIncludeDir = "$InterfaceDir/include"; $DpkgDevcdDir = "$InterfaceDir/devcd"; $DpkgDatDir = "$InterfaceDir/dat"; $DpkgThxDir = "$InterfaceDir/thx"; $DpkgMugDir = "$InterfaceDir/mug"; $DpkgDocDir = "$InterfaceDir/doc"; $DpkgLibDir = "$InterfaceDir"; $DpkgBinDir = "$InterfaceDir"; # Define where we might find our artifacts # The search order is: Platform, Product, --Uses extensions,Target, MachineType # Much of this list, and its described in the build.pl file, use the JATS # generated information to extract the correct information # # Only add the directory to the list if it actually exists # This will speed up searching later. # # Create multiple search paths # One for an exaustive search # Others for selective searchs # # foreach my $part ( $BuildFileInfo->getPlatformParts($Platform), $MachType ) { next unless ( $part ); foreach my $subdir ( "lib." . "$part", "lib." . "$part" . "$BuildType", "lib/lib." . "$part" . "$BuildType", "lib/$part" . "$BuildType", "lib/$part" ) { if ( -d "$DpkgLibDir/$subdir" ) { UniquePush( \@{$DpkgLibDirList{_ALL_}}, $subdir); UniquePush( \@{$DpkgLibDirList{$part}}, $subdir); } } } foreach my $part ( $BuildFileInfo->getPlatformParts($Platform), $MachType ) { next unless ( $part ); foreach my $subdir ( "bin." . "$part" . "$BuildType", "bin." . "$part", "bin/bin." . "$part" . "$BuildType", "bin/" . "$part" . "$BuildType", "bin/" . uc($part) . "$BuildType", "bin/$part", "bin." . "$part" . "P", "bin/bin." . "$part" . "P", "bin/" . "$part" . "P", "bin/" . uc($part) . "P" ) { if ( -d "$DpkgBinDir/$subdir" ) { UniquePush( \@{$DpkgBinDirList{_ALL_}}, $subdir); UniquePush( \@{$DpkgBinDirList{$part}}, $subdir); } } } # Here we are going to build the same lists but for the $AlternateBuildType # (i.e P if $BuildType=D) # We use these when we need to work with both production and debug files. foreach my $part ( $BuildFileInfo->getPlatformParts($Platform), $MachType ) { next unless ( $part ); foreach my $subdir ( "lib." . "$part", "lib." . "$part" . "$AlternateBuildType", "lib/lib." . "$part" . "$AlternateBuildType", "lib/$part" . "$AlternateBuildType", "lib/$part" ) { if ( -d "$DpkgLibDir/$subdir" ) { UniquePush( \@{$DpkgLibDirListAlternate{_ALL_}}, $subdir); UniquePush( \@{$DpkgLibDirListAlternate{$part}}, $subdir); } } } foreach my $part ( $BuildFileInfo->getPlatformParts($Platform), $MachType ) { next unless ( $part ); foreach my $subdir ( "bin." . "$part" . "$AlternateBuildType", "bin." . "$part", "bin/bin." . "$part" . "$AlternateBuildType", "bin/" . "$part" . "$AlternateBuildType", "bin/" . uc($part) . "$AlternateBuildType", "bin/$part", "bin." . "$part" . "P", "bin/bin." . "$part" . "P", "bin/" . "$part" . "P", "bin/" . uc($part) . "P" ) { if ( -d "$DpkgBinDir/$subdir" ) { UniquePush( \@{$DpkgBinDirListAlternate{_ALL_}}, $subdir); UniquePush( \@{$DpkgBinDirListAlternate{$part}}, $subdir); } } } Information("------------------------------------------------------------"); # lets generate the patch id if we are building a patch # if ( "x$PkgPatchNum" ne "x" ) { Information("This is a PATCH build..."); $PkgPatchName = uc ($PkgName); my ($_tmpStr) = sprintf("%s%s", $PkgPatchName, $PkgVersionStr); $PkgPatchID = "$_tmpStr" . "-" . "$PkgPatchNum"; $PkgPatchReadme = "$PkgBaseDir" . "/README." . "$PkgPatchID"; $PkgPatchTmpDir = "$PkgBaseDir/tmp"; $PkgReleaseNote = "$ReleaseDir" . "/$PkgPatchName" . "$PkgVersionStr\_" . "$PkgPatchNum\_" . "$ProjectAcronym\_" . "$Platform"; $PkgLabel = uc ($ProjectAcronym) . "_" . $PkgPatchName . "_" . $PkgVersionStr . "_P" . $PkgPatchNum; # lets define what our output package name shall be # $PkgOutputFile = "na"; } else { Information("This is a normal RELEASE build..."); $PkgReleaseNote = "$ReleaseDir" . "/" . "$PkgName" . "-" . "$PkgVersion" . "." . "$ProjectAcronym" . "-" . "$Platform"; $PkgLabel = uc ($ProjectAcronym) . "_" . uc ($PkgName) . "_" . "R_" . "$PkgVersionStr"; # lets define what our output package name shall be # $PkgOutputFile = "$PkgName" . "-" . "$PkgVersion" . "." . "$ProjectAcronym" . "-" . "$Platform" . "-" . "$BuildType\.pkg"; } Information("------------------------------------------------------------"); # lets just show what we have determined. # Information("Current environment definitions (Increase Verbose Level to see all definitions)..."); Verbose("DeployFiles =[$PKG_UTIL_DIR]"); Information("PkgName =[$PkgName]"); Information("PkgVersionUser =[$PkgVersionUser]"); Information("PkgVersion =[$PkgVersion]"); Information("PkgVersionStr =[$PkgVersionStr]"); Information("PkgBuildNum =[$PkgBuildNum]"); if ( "x$PkgPatchID" ne "x" ) { Information("PkgPatchName =[$PkgPatchName]"); Information("PkgPatchNum =[$PkgPatchNum]"); Information("PkgPatchID =[$PkgPatchID]"); Information("PkgPatchTmpDir =[$PkgPatchTmpDir]"); } Information("PkgReleaseNote =[Generated later by ABT]"); Information("PkgLabel =[$PkgLabel]"); Information("PkgPreviousVersionStr=[$PkgPreviousVersionStr]"); Information("ProjectAcronym =[$ProjectAcronym]"); Information("BuildType =[$BuildType]"); Information("MachType =[$MachType]"); Information("MachArch =[$MachArch]") if ( $MachArch ); Information("MachISA =[$MachISA]") if ( $MachISA ); Information("Platform =[$Platform]"); Information("Product =[$Product]"); Information("Target =[$Target]"); Verbose("BuildParts =[" . join(',',$BuildFileInfo->getPlatformParts($Platform)) . "]"); Information("CurrentDir =[$CurrentDir]"); Information("RootDir =[$RootDir]"); Information("Username =[$Username]"); Information("TargetBaseDir =[" . ($TargetBaseDir ne "." ? $TargetBaseDir : $opt_d) . "]"); Information("TargetHomeDir =[$TargetHomeDir]"); Information("SrcDir =[$SrcDir]"); Information("PkgDir =[$PkgDir]"); Information("PkgBaseDir =[$PkgBaseDir]"); Information("ReleaseDir =[$ReleaseDir]"); Verbose("InterfaceDir =[$InterfaceDir]"); Verbose("DpkgScriptsDir =[$DpkgScriptsDir]"); Verbose("DpkgBinDir(s) =["); foreach $i (@{$DpkgBinDirList{'_ALL_'}}) { Verbose(" $DpkgBinDir/$i"); } Verbose(" ]"); Verbose("DpkgLibDir(s) =["); foreach $i (@{$DpkgLibDirList{'_ALL_'}}) { Verbose(" $DpkgLibDir/$i"); } Verbose(" ]"); Verbose("DpkgEtcDir =[$DpkgEtcDir]"); Verbose("DpkgJarDir =[$DpkgJarDir]"); Verbose("DpkgSarDir =[$DpkgSarDir]"); Verbose("DpkgWarDir =[$DpkgWarDir]"); Verbose("DpkgSqlDir =[$DpkgSqlDir]"); Verbose("DpkgJspDir =[$DpkgJspDir]"); Verbose("DpkgRoxDir =[$DpkgRoxDir]"); Verbose("DpkgRptDir =[$DpkgRptDir]"); Verbose("DpkgAcHtmlDir =[$DpkgAcHtmlDir]"); Verbose("DpkgIncludeDir =[$DpkgIncludeDir]"); Verbose("DpkgDevcdDir =[$DpkgDevcdDir]"); Verbose("DpkgDatDir =[$DpkgDatDir]"); Verbose("DpkgThxDir =[$DpkgThxDir]"); Verbose("DpkgMugDir =[$DpkgMugDir]"); Verbose("DpkgDocDir =[$DpkgDocDir]"); Verbose("DpkgInfoFilesDir =[$DpkgInfoFilesDir]"); Verbose("DpkgPkgDir =[$DpkgPkgDir]"); Verbose("PkgInfoFile =[$PkgInfoFile]"); Verbose("ProtoTypeFile =[$ProtoTypeFile]"); foreach $i ( $BuildFileInfo->getDpkgArchiveList() ) { my $moduleInfo = $BuildFileInfo->getDpkgArchiveInfo($i); Verbose( "Build Dependency =" . "[$moduleInfo->{type}] " . "[$i] " . "[$moduleInfo->{version}] " . "[$moduleInfo->{proj}]"); } if ( "$MachType" eq "sparc" ) { Information("PkgOutputFile =[$PkgOutputFile]"); } Information("PkgOverview =[$PKG_OVERVIEW]"); # Lets evaluate TargetDstDirStructure to expand any vars foreach $i ( keys %TargetDstDirStructure ) { if ( $TargetDstDirStructure{$i} =~ /\$/ ) { Debug("-n", "Expanding TargetDstDirStructure [$TargetDstDirStructure{$i}] to "); $TargetDstDirStructure{$i} = eval "sprintf " . qq/"$TargetDstDirStructure{$i}"/; Information("TargetDstDir $i =[$TargetDstDirStructure{$i}]"); } } # lets check waht we can before proceeding. # ValidateLocalSrcDirStructure(); # Everything went ok lets begin by creating some dirs... # CreateTargetDirStructure(); # done return 1; } #------------------------------------------------------------------------------ sub setPkgDescription # # Description: # This sub-routine is used to set the Package DESC field # from within the deployfile. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to setPkgDescription() function.", "Check deploy config."); } my ($lpkgDesc) = shift; # we use what was defined in deployfile if # the RM details are not available if ( ! defined($RmPkgDetails) ) { $PkgDesc = $lpkgDesc; } else { # let's use the details if we have them if ( $RmPkgDetails->foundDetails() ) { # we have RM details, we will only use them # if nothing is locally defined, # (ie locally defined details takes precedence) if ( "x$lpkgDesc" eq "x" ) { $PkgDesc = $RmPkgDetails->pv_description(); } else { $PkgDesc = $lpkgDesc; } } else { $PkgDesc = $lpkgDesc; } } # done return 1; } #------------------------------------------------------------------------------ sub setPkgName # # Description: # This sub-routine is used to set the Package NAME field # from within the deployfile. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "setPkgName() function. ", "Check deploy config."); } $PkgNameLong = shift; # done return 1; } #------------------------------------------------------------------------------ sub setErgAfcBaseDir # # Description: # This sub-routine is used to reset the ERG AFC base dir global variable # from within the deployfile. # #------------------------------------------------------------------------------ { # if TargetBaseDir is empty then init has not been called yet so we can set # base dir, if however it is not null then init has been called and setting # base dir after init causes problems in some cases. if ( $TargetBaseDir ne "" ) { Error("setErgAfcBaseDir() cannot be called after Init(), place before Init() in deployfile.pl"); } # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "setErgBaseDir() function. ", "Check deploy config."); } my ($newDir) = @_; $ERGAFC_BASEDIR = "$newDir"; return 1; } #------------------------------------------------------------------------------ sub getErgAfcBaseDir # # Description: # This sub-routine is used to get the ERG AFC base dir global variable # to be used within the deployfile. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 0 ) { Error("Incorrect number of params passed to " . "getErgBaseDir() function. ", "Check deploy config."); } return "$ERGAFC_BASEDIR"; } #------------------------------------------------------------------------------ sub setPkgOverview # # Description: # This sub-routine is used to reset the package overview that # is used to build the package from within the deployfile. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "setPkgOverview() function. ", "Check deploy config."); } my ($mStr) = @_; $PKG_OVERVIEW = "$mStr"; return 1; } #------------------------------------------------------------------------------ sub getPkgOverview # # Description: # This sub-routine is used to get the package overview string global variable # to be used within the deployfile. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 0 ) { Error("Incorrect number of params passed to " . "getPkgOverview() function. ", "Check deploy config."); } return "$PKG_OVERVIEW"; } #------------------------------------------------------------------------------ sub addInstallshieldFiles # # Description: # This is called to add extra installshield files to the PKG_ISHIELD_FILES array. # For each parameter it checks for the existense of arg.* in the PKG_UTIL_DIR # and adds all found files to the array # This must be called before init() is called. # # INPUT: # files to add # # RETURN: # nothing # #------------------------------------------------------------------------------ { my @files; # lets just check to see if we can execute this function on this machine. if ( "$MachType" eq "sparc" ) { Warning("addInstallshieldFiles() not supported on this machine type."); return 1; } foreach my $i ( @_ ) { @files = glob("$PKG_UTIL_DIR/$i.*"); foreach my $j ( @files ) { $j = basename($j); Verbose("Adding Installshield file $j"); push(@PKG_ISHIELD_FILES, $j); } } return 1; } # addInstallshieldFiles #------------------------------------------------------------------------------ sub removeBuildTypeFromItemName # # Description: # This sub-routine is used to remove the buildtype from the item name. # i.e. debug files will be tagged with *D.* # prod file will be tagged with *P.* # # INPUT: # item name # # RETURN: # new item name. # #------------------------------------------------------------------------------ { my ($file) = @_; my ($nfile) = $file; $nfile =~ s/D\.|P\./\./; return "$nfile"; } #------------------------------------------------------------------------------ sub installAllDpkgArchivePkgFiles # # Description: # This sub-routine is used to install all infofiles files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # Source directory: $DpkgPkgDir (interface/pkg) # Target directory: $PkgBaseDir (output/pkg/[debug|prod] # #------------------------------------------------------------------------------ { # # Use the (now) more general function installAllDpkgArchivePkgFiles2 # with spacial parameters to mimic the original function # # Copy all from the 'pkg' directory to the PkgBaseDir # installAllDpkgArchivePkgFiles2 ( "--Dstdir=$PkgBaseDir", '--Srcdir=pkg', @_ ); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchivePkgFiles2 # # Description: # This sub-routine is used to install all pkg files from the # dpkg_archive into the defined install area. # # Simlar to installAllDpkgArchivePkgFiles, but the target directory # is specified by the user. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # Inputs : targetTag - Target directory [Mandatory] # options - Optional options # --Srcdir=path [default=pkg] # --Dstdir=abs_path [internal use] # --NoRecurse # --Recurse [default] # --Flatten # --NoFlatten [default] # --FilterIn=xx # --FilterInRE=xx [default=.*] # --FilterOut=xx # --FilterOutRE=xx # # Notes: --FilterIn=xxxx, --FilterOut=xxx # xxx is a simple Shell style filter where: # * means one or more charters '*.EXE' # ? means a single character '*.?' # [abc] means either a or b or c 'file.[ch]' # # --FilterInRE=xxx, --FilterOutRE=xxx # xxx is a Regular Expression. There are harder to use but very # powerful. ie '.*\.EXE$' # # The 'In' filters are applied before the 'Out' filters. # # If no 'In' filters are specified then all files will be included. # # The filter rules are applied to the path below the Srcdir, and, for # the purposes of the filter the path starts with a '/'. # #------------------------------------------------------------------------------ { my $src_base_dir; my $flatten = 0; my $dstDir; my $search = LocateFiles->new(recurse => 1); Information("Installing all Prepared pkg files..."); # # Process the arguments and extract parameters and options # foreach ( @_ ) { if ( m/^--Srcdir=(.*)/ ) { Error("installAllDpkgArchivePkgFiles2: Multiple --Srcdir not allowed") if ( $src_base_dir ); $src_base_dir = "$InterfaceDir/$1"; $src_base_dir =~ s~/\.$~~; $src_base_dir =~ s~/$~~; } elsif ( /^--Dstdir=(.*)/ ) { Error("installAllDpkgArchivePkgFiles2: Multiple target directories not allowed") if ( $dstDir ); $dstDir = $1; } elsif ( m/^--NoRecurse/ ) { $search->recurse(0); } elsif ( m/^--Recurse/ ) { $search->recurse(1); } elsif ( /^--FilterOut=(.*)/ ) { $search->filter_out( $1 ); } elsif ( /^--FilterOutRE=(.*)/ ) { $search->filter_out_re( $1 ); } elsif ( /^--FilterIn=(.*)/ ) { $search->filter_in( $1 ); } elsif ( /^--FilterInRE=(.*)/ ) { $search->filter_in_re( $1 ); } elsif ( /^--Flatten/ ) { $flatten = 1; } elsif ( /^--NoFlatten/ ) { $flatten = 0; } elsif ( m/^--/ ) { Error("installAllDpkgArchivePkgFiles2: Unknown option: $_") } else { Error("installAllDpkgArchivePkgFiles2: Multiple target directories not allowed") if ( $dstDir ); # Convert the symbolic target directory name into a real path $dstDir = getTargetDstDirValue($_, "A"); } } # # Ensure that we have a valid source directory # Data taken from the 'pkg' directory unless otherwise specified by the user # $src_base_dir = $DpkgPkgDir unless $src_base_dir; Error("installAllDpkgArchivePkgFiles2: Package directory not found: $src_base_dir") unless ( -d $src_base_dir ); # # Ensure that the user has specified a target directory # Error("installAllDpkgArchivePkgFiles2: No target directories specified") unless ( $dstDir ); # # Build up a list of files to copy # Creating a list allows: # Simplified coding # Flattening and testing of the flattening # my @elements = $search->search( $src_base_dir); Warning("installAllDpkgArchivePkgFiles2: No files found") unless ( @elements ); # # Perform the file copy # This copy will NOT create empty directories, but it will create needed # directories on the fly. # foreach my $sfile ( @elements ) { # # Split into directory and file as we may need to make the directory # since the copy operation will not # my $dir; # Target directory my $tfile; # Target path (my $fname = $sfile )=~ s~^.*/+~~; # Filename(only) unless ( $flatten ) { $sfile =~ m~^(.*/)~; $dir = "$dstDir/$1"; $tfile = $sfile; } else { $dir = $dstDir; $tfile = $fname; } # # Ensure the target directory is present # make_directory ( $dir, 0775 ); # # Copy the file # Ensure that the target file does not already exist # This is most likely to occur when flattening the directory structure # my $m_sfile = "$src_base_dir$sfile"; my $m_tfile = "$dstDir/$tfile"; if ( -f $m_tfile ) { Error("Failed to copy file [$m_sfile] to [$m_tfile]: File already exists"); } if( File::Copy::copy("$m_sfile", "$m_tfile") ) { Verbose("Copied [$fname] to [$m_tfile] ..."); } else { Error("Failed to copy file [$m_sfile] to [$m_tfile]: $!"); } } return 1; } #------------------------------------------------------------------------------ sub installDpkgArchivePkgRaw # # Description: # This sub-routine is used to install all pkg files from the named package # in dpkg_archive into the defined install area. # # If it has any problems it will log an error and stop processing. # # Inputs : targetTag - Target directory [Mandatory] # package - Source Package [Mandatory] # options - Optional options # --Subdir=path [Default is pkg root] # --NoRecurse # --Recurse [default] # --Flatten # --NoFlatten [default] # --FilterIn=xx # --FilterInRE=xx [default=.*] # --FilterOut=xx # --FilterOutRE=xx # --Warn [ default] # --NoWarn # # Notes: --FilterIn=xxxx, --FilterOut=xxx # xxx is a simple Shell style filter where: # * means one or more charters '*.EXE' # ? means a single character '*.?' # [abc] means either a or b or c 'file.[ch]' # # --FilterInRE=xxx, --FilterOutRE=xxx # xxx is a Regular Expression. There are harder to use but very # powerful. ie '.*\.EXE$' # # The 'In' filters are applied before the 'Out' filters. # # If no 'In' filters are specified then all files will be included. # # The filter rules are applied to the path below the Srcdir, and, for # the purposes of the filter the path starts with a '/'. # # # --NoWarn # Supresses the warning message generated if no files are transferred # #------------------------------------------------------------------------------ { my $flatten = 0; my $dstDir; my @args; my $src_base_dir; my $warning = 1; my $search = LocateFiles->new(recurse => 1); my $subdir; # # Process the arguments and extract parameters and options # foreach ( @_ ) { if ( m/^--NoRecurse/ ) { $search->recurse(0); } elsif ( m/^--Recurse/ ) { $search->recurse(1); } elsif ( /^--FilterOut=(.*)/ ) { $search->filter_out( $1 ); } elsif ( /^--FilterOutRE=(.*)/ ) { $search->filter_out_re( $1 ); } elsif ( /^--FilterIn=(.*)/ ) { $search->filter_in( $1 ); } elsif ( /^--FilterInRE=(.*)/ ) { $search->filter_in_re( $1 ); } elsif ( /^--Flatten/ ) { $flatten = 1; } elsif ( /^--NoFlatten/ ) { $flatten = 0; } elsif ( /^--NoWarn/ ) { $warning = 0; } elsif ( /^--Warn/ ) { $warning = 1; } elsif ( /^--Subdir=(.*)/ ) { $subdir = $1; } elsif ( m/^--/ ) { Error("installDpkgArchivePkgRaw: Unknown option: $_") } else { push @args, $_; } } # # Have removed all the options # Must have two parameters left # if ( $#args != 1 ) { Error("Incorrect number of params passed to installDpkgArchivePkgRaw() function.", "Check deploy config."); } my ( $dstDirTag, $pkgName ) = @args; # # Ensure that the user has specified a target directory # Convert the symbolic target directory to a real path # Error("installDpkgArchivePkgRaw: No target directories specified") unless ( $dstDirTag ); $dstDir = getTargetDstDirValue($dstDirTag, "A"); # # Convert the package name into a real path name to the package as # held in dpkg_archive. Do not use the copy in the 'interface' directory # $src_base_dir = LocatePackageBase ( "installDpkgArchivePkgRaw", $pkgName, $subdir ); # # Build up a list of files to copy # Creating a list allows: # Simplified coding # Flattening and testing of the flattening # my @elements = $search->search( $src_base_dir ); Information("Installing Raw Pkg files: $pkgName") if @elements; # # Perform the file copy # This copy will NOT create empty directories, but it will create needed # directories on the fly. # foreach my $sfile ( @elements ) { # # Split into directory and file as we may need to make the directory # since the copy operation will not # my $dir; # Target directory my $tfile; # Target path (my $fname = $sfile )=~ s~^.*/+~~; # Filename(only) unless ( $flatten ) { $sfile =~ m~^(.*/)~; $dir = "$dstDir/$1"; $tfile = $sfile; } else { $dir = $dstDir; $tfile = $fname; } # # Ensure the target directory is present # make_directory ( $dir, 0775 ); # # Copy the file # Ensure that the target file does not already exist # This is most likely to occur when flattening the directory structure # my $m_sfile = "$src_base_dir$sfile"; my $m_tfile = "$dstDir/$tfile"; if ( -f $m_tfile ) { Error("Failed to copy file [$m_sfile] to [$m_tfile]: File already exists"); } if( File::Copy::copy("$m_sfile", "$m_tfile") ) { Verbose("Copied [$fname] to [$m_tfile] ..."); } else { Error("Failed to copy file [$m_sfile] to [$m_tfile]: $!"); } } # # Return the number of files transferred # my $nfiles = $#elements + 1; Warning("Installing Raw Pkg files: $pkgName - No files transferred") if ( $warning && ! $nfiles ) ; return $nfiles; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveDevcdFiles # # Description: # This sub-routine is used to install all devcd files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # Source directory: $DpkgDevcdDir (interface/devcd) # Target directory: Symbolic Directory # # Inputs: None # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveDevcdFiles() function. ", "Check deploy config."); } Information("Installing all Prepared Day 0 devcd files..."); my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "R"); # ok we have a valid dst value we now need to get a hold of all the # lib scripts files. # if ( "$MachType" eq "win32" || "$MachType" eq "WinCE" ) { $TmpGlobalVariable = $targetValue; File::Find::find( \&pkgFindDevcd, "$DpkgDevcdDir"); } else { my ($i); my(@FindRes) = `find $DpkgDevcdDir -follow`; my ($m_sfile); my ($tmp_DstDir) = "$PkgBaseDir/$targetValue"; my ($tmp_SrcDir) = "$DpkgDevcdDir"; foreach $i (@FindRes) { chomp($i); my($base)= File::Basename::basename($i); if ( $base eq "devcd" ) { next; } my ($tmp_dItem) = $i; $tmp_dItem =~ s/$tmp_SrcDir/$tmp_DstDir/; if ( -d $i ) { make_directory ( $tmp_dItem, 0775 ); } else { if(File::Copy::copy( $i , $tmp_dItem )) { Verbose("Copied [$base] to [$tmp_dItem] ..."); } else { Error("Failed to copy pkg file [$tmp_dItem] to [$i]: $!"); } } } } return 1; } #------------------------------------------------------------------------------ sub pkgFindDevcd # # Description: # This subroutine is used to locate all associated devcd files in # a pre-defined dpkg_archive. # # Trick: Will not copy a file/directory called 'devcd' # Not too sure why. May be an attempt to prevent empty devcd directories # If you know better, then correct this comment. #------------------------------------------------------------------------------ { my($item)= "$File::Find::name"; my($base)= File::Basename::basename($item); if ( $base eq "devcd" ) { return 1; } my ($tmp_dItem) = $item; my ($tmp_DstDir) = "$PkgBaseDir/$TmpGlobalVariable"; my ($tmp_SrcDir) = "$DpkgDevcdDir"; $tmp_dItem =~ s/$tmp_SrcDir/$tmp_DstDir/; # we need to determine what type of item we are dealing with file we are dealing with if ( -d "$item") { make_directory( $tmp_dItem, 0775 ); } else { if(File::Copy::copy("$item", "$tmp_dItem")) { Verbose("Copied [$base] to [$tmp_dItem] ..."); } else { Error("Failed to copy pkg file [$tmp_dItem] to [$item]: $!"); } } } #------------------------------------------------------------------------------ sub installAllDpkgArchiveFiles # # Description: # This sub-routine is used to install all files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # Inputs: $targetType - Internal tag to specify source file # $targetTag - Users tag for destination # # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveFiles() function. ", "Check deploy config."); } my ($targetType, $targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my $targetValue; if ( $targetTag eq "--NoTag" ) { $targetValue = ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir; } else { $targetValue = getTargetDstDirValue($targetTag, "A"); } # ok we have a valid dst value we now need to get a hold of all the # lib scripts files. # local *DIR; my $src_dir; if ( "$targetType" eq "jar" ) { $src_dir = $DpkgJarDir; } elsif ( "$targetType" eq "sar" ) { $src_dir = $DpkgSarDir; } elsif ( "$targetType" eq "include" ) { $src_dir = $DpkgIncludeDir; } elsif ( "$targetType" eq "war" ) { $src_dir = $DpkgWarDir; } elsif ( "$targetType" eq "infofiles" ) { $src_dir = $DpkgInfoFilesDir; } elsif ( "$targetType" eq "sql" ) { $src_dir = $DpkgSqlDir; } elsif ( "$targetType" eq "etc" ) { $src_dir = $DpkgEtcDir; } elsif ( "$targetType" eq "scripts" ) { $src_dir = $DpkgScriptsDir; } elsif ( "$targetType" eq "rox" ) { $src_dir = $DpkgRoxDir; } elsif ( "$targetType" eq "rpt" ) { $src_dir = $DpkgRptDir; } elsif ( "$targetType" eq "doc" ) { $src_dir = $DpkgDocDir; } elsif ( "$targetType" eq "jsp" ) { $src_dir = $DpkgJspDir; } # elsif ( "$targetType" eq "achtml" ) { $src_dir = $DpkgAcHtmlDir; } else { Error("installAllDpkgArchiveFiles() passed unknown target type [$targetType]."); } opendir(DIR, $src_dir) or Error("Can't opendir $src_dir: $!"); # lets process what we have found # my ($file); while (defined($file = readdir(DIR))) { if ( $file !~ /^.$/ && $file !~ /^..$/ ) { my ($m_fLoc) = "$src_dir/$file"; if(File::Copy::copy("$m_fLoc", "$targetValue")) { Verbose("Copied [$targetType] item [$file] to [$targetValue] ..."); } else { Error("Failed to copy [$targetType] item [$m_fLoc]: $!"); } } } closedir(DIR); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveAcHtmlFiles # # Description: # This sub-routine is used to install all achtml files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # # Ugly trick: # This function tags a $$targetType argument which is used in constructing # the source directory path. ie: InterfaceDir/achtml/$targetType # # Could provide as an option to installAllDpkgArchiveFiles and re-use that # function # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveAcHtmlFiles() function. ", "Check deploy config."); } my ($targetType, $targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # lets check to see if the source type dir actually exists # my($m_sDirLoc) = "$DpkgAcHtmlDir/$targetType"; if( ! -d "$m_sDirLoc" ) { Error("Failed to locate [$targetType] AcHtml dir [$m_sDirLoc]."); } # know everything exists so lets do the biz. # # now we need to copy all the files. # local *DIR; opendir(DIR, $m_sDirLoc) or Error("Can't opendir $m_sDirLoc: $!"); my ($m_fLoc) = ""; my ($file) = ""; while (defined($file = readdir(DIR))) { if ( $file !~ /^.$/ && $file !~ /^..$/ ) { $m_fLoc = "$m_sDirLoc/$file"; if(File::Copy::copy("$m_fLoc", "$targetValue")) { Verbose("Copied AcHtml [$targetType] item [$file] to [$targetValue] ..."); } else { Error("Failed to copy AcHtml [$targetType] item [$m_fLoc]: $!"); } } } closedir(DIR); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveInfoFilesFiles # # Description: # This sub-routine is used to install all infofiles files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveInfoFilesFiles() function. ", "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("infofiles", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveSqlFiles # # Description: # This sub-routine is used to install all sql files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveSqlFiles() function. ", "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("sql", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveWarFiles # # Description: # This sub-routine is used to install all war files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveWarFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("war", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveJarFiles # # Description: # This sub-routine is used to install all jar files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveJarFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("jar", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveEtcFiles # # Description: # This sub-routine is used to install all etc files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveEtcFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("etc", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveScriptsFiles # # Description: # This sub-routine is used to install all scripts files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveScriptsFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("scripts", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveIncludeFiles # # Description: # This sub-routine is used to install all include files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveIncludeFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("include", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveDocFiles # # Description: # This sub-routine is used to install all include files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveIncludeFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # for now lets call the generic funtion to move all items # in the associated dpkg_archive dir. # installAllDpkgArchiveFiles("doc", $targetTag); return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveJspFiles # # Description: # This sub-routine is used to install all jsp associated files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # # Source directory: $DpkgJspDir # Target directory: $TargetBaseDir # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 0 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveJspFiles() function. " , "Check deploy config."); } return installAllDpkgArchiveFiles ('jsp', '--NoTag'); } #------------------------------------------------------------------------------ sub installDpkgArchiveFile # # Description: # This sub-routine is used to install a file of a particular type # from the dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # # Inputs: $targetType - Type of target ( provides source directory) # $sfile - Source file name, within source directory # $targetTag - Symbolic target dir # $tfile - Optional # # # Note: This function will copy a single file # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) < 3 || ($#_+1) > 4 ) { Error("Incorrect number of params passed to " . "installDpkgArchiveFile() function. " , "Check deploy config."); } my ($targetType, $sfile, $targetTag, $tfile) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # # Set the name of the target file to that of the source file # if the name is not provided by the user # $tfile = $sfile if ( !defined $tfile || $tfile eq "" ); # lets define the absolute location of the file # my ($m_dstFileLocation) = "$targetValue/$tfile"; my ($m_srcFileLocation) = ""; if ( "$targetType" eq "jar" ) { $m_srcFileLocation = "$DpkgJarDir/$sfile"; } elsif ( "$targetType" eq "sar" ) { $m_srcFileLocation = "$DpkgSarDir/$sfile"; } elsif ( "$targetType" eq "include" ) { $m_srcFileLocation = "$DpkgIncludeDir/$sfile"; } elsif ( "$targetType" eq "war" ) { $m_srcFileLocation = "$DpkgWarDir/$sfile"; } elsif ( "$targetType" eq "infofiles" ) { $m_srcFileLocation = "$DpkgInfoFilesDir/$sfile"; } elsif ( "$targetType" eq "sql" ) { $m_srcFileLocation = "$DpkgSqlDir/$sfile"; } elsif ( "$targetType" eq "etc" ) { $m_srcFileLocation = "$DpkgEtcDir/$sfile"; } elsif ( "$targetType" eq "scripts" ) { $m_srcFileLocation = "$DpkgScriptsDir/$sfile"; } elsif ( "$targetType" eq "rox" ) { $m_srcFileLocation = "$DpkgRoxDir/$sfile"; } elsif ( "$targetType" eq "dat" ) { $m_srcFileLocation = "$DpkgDatDir/$sfile"; } elsif ( "$targetType" eq "thx" ) { $m_srcFileLocation = "$DpkgThxDir/$sfile"; } elsif ( "$targetType" eq "mug" ) { $m_srcFileLocation = "$DpkgMugDir/$sfile"; } elsif ( "$targetType" eq "rpt" ) { $m_srcFileLocation = "$DpkgRptDir/$sfile"; } elsif ( "$targetType" eq "doc" ) { $m_srcFileLocation = "$DpkgDocDir/$sfile"; } else { Error("installDpkgArchiveFile() passed unknown target type [$targetType]."); } # we will check to see if the file exists. # if ( -f "$m_srcFileLocation" ) { # now we need to copy the file. if(File::Copy::copy("$m_srcFileLocation", "$m_dstFileLocation")) { Verbose("Copied [$targetType] item [$sfile] to [$m_dstFileLocation] ..."); } else { Error("Failed to copy [$targetType] item [$sfile]: $!"); } } else { Error("Dpkg_archive [$targetType] item [$sfile] does not exist."); } return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveAcHtmlFile # # Description: # This sub-routine is used to install a achtml file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # # Ugly trick: # This function tags a $targetType argument which is used in constructing # the source directory path. ie: InterfaceDir/achtml/$targetType # # Could provide as an option to installDpkgArchiveFile and re-use that # function #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 3 ) { Error("Incorrect number of params passed to " . "installDpkgArchiveAcHtmlFile() function. " , "Check deploy config."); } my ($targetType, $sfile, $targetTag) = @_; # lets check to see if the source type and file actually exist # my($m_sDirLoc) = "$DpkgAcHtmlDir/$targetType"; if( ! -d "$m_sDirLoc" ) { Error("Failed to locate [$targetType] AcHtml dir [$m_sDirLoc]."); } # lets check to see if the file exists # my($m_sFileLoc) = "$DpkgAcHtmlDir/$targetType/$sfile"; if( ! -f "$m_sFileLoc" ) { Error("Failed to locate [$targetType] AcHtml file [$m_sFileLoc]."); } # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # know everything exists so lets do the biz. # # now we need to copy the file. if(File::Copy::copy("$m_sFileLoc", "$targetValue")) { Verbose("Copied [$targetType] AcHtml item [$sfile] to [$targetValue] ..."); } else { Error("Failed to copy [$targetType] AcHtml item [$sfile]: $!"); } return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveRptFile # # Description: # This sub-routine is used to install a rpt file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("rpt", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveRoxFile # # Description: # This sub-routine is used to install a rox file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("rox", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveDatFile # # Description: # This sub-routine is used to install a dat file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("dat", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveThxFile # # Description: # This sub-routine is used to install a thx file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("thx", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveMugFile # # Description: # This sub-routine is used to install a mug file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("mug", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveInfoFilesFile # # Description: # This sub-routine is used to install a infofiles file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("infofiles", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveSqlFile # # Description: # This sub-routine is used to install a sql file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("sql", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveWarFile # # Description: # This sub-routine is used to install a war file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("war", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveJarFile # # Description: # This sub-routine is used to install a jar file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("jar", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveSarFile # # Description: # This sub-routine is used to install a sar file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("sar", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveEtcFile # # Description: # This sub-routine is used to install an etc file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("etc", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveScriptsFile # # Description: # This sub-routine is used to install a scripts file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("scripts", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveIncludeFile # # Description: # This sub-routine is used to install a include file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("include", @_); return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveDocFile # # Description: # This sub-routine is used to install a include file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # #------------------------------------------------------------------------------ { # Use generic funtion to move all items in the associated dpkg_archive dir. # installDpkgArchiveFile("doc", @_); return 1; } #------------------------------------------------------------------------------ sub copyDpkgArchiveBinFile # # Description: # This sub-routine is used to find a binary file from the # dpkg_archive and copy it into the supplied install dir. # # If it fails to find the file it will report an error and terminates # processing. # # Inputs : @srcDirList - array of subdirectories to search # within the $DpkgBinDir # $srcFilename - file to find then copy # $destDir - destination directory # $rename - Optional Rename # # # Returns : Nothing of use # Will not return if the file is not found # #------------------------------------------------------------------------------ { my ($srcDirList, $srcFilename, $destDir, $rename ) = @_; if ( "$MachType" eq "win32" ) { # if the item does not have an .exe extention # we shall add one for convience. # $srcFilename .= '.exe' if ( $srcFilename !~ m~\.(exe)|(dll)$~i ); $rename .= '.exe' if ( $rename && $rename !~ m~\.(exe)|(dll)$~i ); } foreach my $i (@$srcDirList) { my $m_DpkgDir = "$DpkgBinDir/$i"; if ( ! -d $m_DpkgDir ) { Debug("Directory [$m_DpkgDir] not found."); next; } # Define the absolute location of the file # my $m_srcFileLocation = "$m_DpkgDir/$srcFilename"; my $m_dstFileLocation = "$destDir/" . ( $rename ? $rename : $srcFilename ); # we will check to see if the file exists. # if ( -f $m_srcFileLocation ) { # now we need to copy the file. if(File::Copy::copy($m_srcFileLocation, $m_dstFileLocation)) { Verbose("Copied Bin [$srcFilename] to [$m_dstFileLocation] ..."); # no need to go further, we have found the file. # return 1; } else { Error("Failed to copy binary [$srcFilename]: $!"); } } # else we have not found the file yet! } # if we do not find the file at all we need to inform the user. # Error("Dpkg_archive bin file [$srcFilename]", "File does not exist or is not in correct directory structure"); } #------------------------------------------------------------------------------ sub installDpkgArchiveBinFile # # Description: # This sub-routine is used to install a binary file from the # dpkg_archive into the supplied install dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # # Inputs : $sfile - Name of source file # or a reference to a list of files # $targetTag - Symbolic name of target # Options - Optional options # # Options: # --SelectFrom=xxxx - Limits file source selection # By default all LIB sources are searched. # The selector should be a Platform, Product # ,Target or MachineType # # --Rename=xxxx - Rename the file during the copy operation # Not valid if $sfile is a ref to a list # # --InstallProdAndDebug - install both production and debug # versions of any binary files # in bin/P and bin/D sub-dirs, # and create a links/copy of the # file for the $BuildType # in the actual bin directory. # (only tested for sparc) # # Returns : Nothing of use # Will not return if the file is not found # #------------------------------------------------------------------------------ { my @args; my $select = '_ALL_'; my $rename = ""; my $installProdAndDebug; # # Process parameters and extract options # foreach ( @_ ) { if ( m/^--SelectFrom=(.*)/ ) { $select = $1; Error("installDpkgArchiveBinFile: Selector not known: $_") unless ( defined $DpkgLibDirList{$select} ); } elsif ( m/^--InstallProdAndDebug/ ) { if ( "$MachType" eq "sparc" ) { $installProdAndDebug = 1; } else { Error("--InstallProdAndDebug option only supported for sparc."); } } elsif ( m/^--Rename=(.+)/ ) { $rename = $1; } elsif ( m/^--/ ) { Warning ("installDpkgArchiveBinFile: Unknown option ignored: $_") } else { push @args, $_; } } # correct number of parameters? my ($fref, $targetTag) = @_; if ( $#args != 1 ) { Error("Incorrect number of params passed to " . "installDpkgArchiveBinFile() function. " , "Check deploy config."); } # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # # Process the file name # This will either be a scalar name, or a reference to an array of names # If the user has provided an array of names then expand the list # # Convert $fref into an reference to a list # my @one_file; unless ( ref ( $fref ) eq 'ARRAY' ) { push @one_file, $fref; $fref = \@one_file; } else { Error ("installDpkgArchiveBinFile. --Rename option cannot be used with a list of files") if $rename; } foreach my $sfile ( @$fref ) { if ( $installProdAndDebug ) { # This option allows you to install both prod and debug binaries. # 1) creates a bin/P and bin/D subdirectory of the bin directory, # 2) copies the binaries into them, then # 3) links/copies from bin/$BuildType to bin directory. # if the bin/P bin/D dirs don't exist, create them. if (! -d "$targetValue/$BuildType" ) { make_directory( "$targetValue/$BuildType", 0777, "Create BinDir/$BuildType dir"); } if (! -d "$targetValue/$AlternateBuildType" ) { make_directory( "$targetValue/$AlternateBuildType", 0777, "Create BinDir/$AlternateBuildType dir"); } # copy in the production and debug binaries. Note the separate search paths. copyDpkgArchiveBinFile(\@{$DpkgBinDirList{$select}}, $sfile, "$targetValue/$BuildType", $rename); copyDpkgArchiveBinFile(\@{$DpkgBinDirListAlternate{$select}}, $sfile, "$targetValue/$AlternateBuildType", "$rename"); # create link (or copy) from bin to bin/$BuildType dir if ( $MachType eq "sparc" ) { # create symbolic link in the bin directory if ( ! -f "$targetValue/$sfile" ) { my $cmd = "cd $targetValue; ln -s $BuildType/$sfile $sfile "; my $retVal = system($cmd); if ( $retVal != 0 ) { Error("Failed to create generic link [$targetValue/$sfile] to [$targetValue/$BuildType/$sfile]: $retVal"); } else { Verbose("Created generic link [$targetValue/$sfile] to [$targetValue/$BuildType/$sfile] ..."); } } } else { # create a copy in the bin directory if(File::Copy::copy("$targetValue/$BuildType/$sfile" , "$targetValue" )) { Verbose("Copied Bin [$targetValue/$BuildType/$sfile] to [$targetValue] ..."); } else { Error("Failed to copy binary [$targetValue/$BuildType/$sfile] to [$targetValue]: $!"); } } } else { copyDpkgArchiveBinFile(\@{$DpkgBinDirList{$select}}, $sfile, $targetValue, $rename ); } } return 1; } #------------------------------------------------------------------------------ sub installDpkgArchiveLibFile # # Description: # This sub-routine is used to install a library file from the # dpkg_archive into the supplied install location dir. # # It assumes based on the build type where the file will be located. # # If it fails to find the file it will report an error and terminates # processing. # # Added optional 3rd parameter & if set to NoLinks then no generic named # libs will be created # # Inputs : $sfile - Name of source file OR # A --Filter specification ( below) # A reference to a list of files OR # $targetTag - Symbolic name of target # $links - Optional. 'nolinks' will supress generic named libs # Options - Optional options # # Options: # --NoLink - same as 3rd arg == nolinks # --Link - Default # --SelectFrom=xxxx - Limits file source selection # By default all LIB sources are searched. # The selector should be a Platform, Product # ,Target or MachineType # --InstallProdAndDebug - install both production and debug # versions of any libraries # (only tested for sparc) # # SourceFile options: # Source files may be a filter rule which will expand to # one or more files. # --FilterIn=xx # --FilterInRE=xx # --FilterOut=xx # --FilterOutRE=xx # # Notes: --FilterIn=xxxx, --FilterOut=xxx # xxx is a simple Shell style filter where: # * means one or more charters '*.EXE' # ? means a single character '*.?' # [abc] means either a or b or c 'file.[ch]' # # --FilterInRE=xxx, --FilterOutRE=xxx # xxx is a Regular Expression. There are harder to use but very # powerful. ie '.*\.EXE$' # # The 'In' filters are applied before the 'Out' filters. # # Multiple options may be joined with a comma. # # Returns : Nothing of use # Will not return if the file is not found # #------------------------------------------------------------------------------ { my @args; my $links = 1; my $select = '_ALL_'; my $installProdAndDebug; # # Process parameters and extract options # foreach ( @_ ) { if ( m/^--NoLink/ ) { $links = 0; } elsif ( m/^--Link/ ) { $links = 1; } elsif ( m/^--SelectFrom=(.*)/ ) { $select = $1; Error("installDpkgArchiveLibFile: Selector not known: $_") unless ( defined $DpkgLibDirList{$select} ); } elsif ( m/^--Filter.*=/ ) { push @args, $_; } elsif ( m/^--InstallProdAndDebug/ ) { # not sure if the filename conventions allow the installation # of both prod/debug files on windows, so limit this to sparc/unix. if ( "$MachType" ne "sparc" ){ Error("Can only use the InstallProdAndDebug option for sparc."); } $installProdAndDebug = 1; } elsif ( m/^--/ ) { Warning ("installDpkgArchiveLibFile: Unknown option ignored: $_") } else { push @args, $_; } } # # Handle the optional 3rd argument # if ( $args[2] ) { $links = $args[2] !~ m/nolink/i; delete $args[2]; } # correct number of parameters? my ($fref, $targetTag) = @_; if ( $#args != 1 ) { Error("Incorrect number of params passed to " . "installDpkgArchiveLibFile() function. " , "Check deploy config."); } # # Check to see if the target tag exists # If does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # # Process the file name # This will either be a scalar name, or a reference to an array of names # If the user has provided an array of names then expand the list # # Convert $fref into an reference to a list # my @one_file; unless ( ref ( $fref ) eq 'ARRAY' ) { push @one_file, $fref; $fref = \@one_file; } # # If the source file contains a pattern, then expand the pattern # This may result in multiple files. # Note: Allow for a single entry of the form # --Filterin=xxx,---FilterOut=yyy # my $search = LocateFiles->new(recurse => 0); my @flist; foreach my $element ( @$fref ) { foreach ( split /,/ , $element ) { if ( /^--FilterOut=(.*)/ ) { $search->filter_out( $1 ); } elsif ( /^--FilterOutRE=(.*)/ ) { $search->filter_out_re( $1 ); } elsif ( /^--FilterIn=(.*)/ ) { $search->filter_in( $1 ); } elsif ( /^--FilterInRE=(.*)/ ) { $search->filter_in_re( $1 ); } elsif ( m/^--/ ) { Warning( "installDpkgArchiveLibFile: Unknown Filter option ignored: $_"); } else { push @flist, $_; } } } # # If any patterns have been found, then expand them # if ( $search->has_filter() ) { foreach my $i (@{$DpkgLibDirList{$select}}) { my @elements = $search->search( "$DpkgLibDir/$i" ); # # Clean off any leading / from each filename then add to a list # Remove any duplicates that were found # map { $_ =~ s~^/~~ } @elements; UniquePush \@flist, @elements; } } # # Process each file # my ($ExcludedFlag) = "false"; foreach my $sfile ( @flist ) { # we exclude .dll files if this is a sparc build # if ( "$MachType" eq "sparc" && $sfile =~ m/\.dll/ ) { Verbose("Excluding item [$sfile] from build, as we do not deliver dlls for this machine type [$MachType]."); $ExcludedFlag = "true"; next; } # we exclude .so files if this is a win32 build # if ( "$MachType" eq "win32" && $sfile =~ m/\.so/ ) { Verbose("Excluding item [$sfile] from build, as we do not deliver sosss for this machine type [$MachType]."); $ExcludedFlag = "true"; next; } my ($libName) = $sfile; if ( "$MachType" eq "sparc" ) { $libName =~ s/\.so.*$//; } # lets define the absolute location of the file my ($m_srcFileLocation) = ""; my ($m_dstFileLocation) = ""; my ($m_DpkgLibDir) = ""; my ($i); my ($j); my ($count); my ($foundFileFlag) = "false"; # # Search all the 'lib' locations, or a specified subset # my (@libDirList) = @{$DpkgLibDirList{$select}}; if ($installProdAndDebug) { # we want to be able to search both prod and debug dirs. # we can just add them together here because the lib filenames # are different (i.e. xxxD.so vs xxxP.so) and a P or D library # will only exist in one dir. i.e. P.so in prod dirs, D.so in debug dirs. push (@libDirList, @{$DpkgLibDirListAlternate{$select}} ) if ( exists($DpkgLibDirListAlternate{$select}) ); } foreach $i (@libDirList) { $m_DpkgLibDir = "$DpkgLibDir" . "/$i"; if ( ! -d "$m_DpkgLibDir" ) { Debug("Directory [$m_DpkgLibDir] not found."); next; } $m_srcFileLocation = "$m_DpkgLibDir/$sfile"; $m_dstFileLocation = "$targetValue/$sfile"; # we only want debug items in a debug build # unless we are told to installProdAndDebug if ( ( !$installProdAndDebug) && (excludeItemFromBuild($sfile)) ) { Verbose("Excluding item [$sfile] from build as not compatible with build type [$BuildType]."); $ExcludedFlag = "true"; } else { # we need to ensure that only a single version/entry of the lib exists in the lib list # $count = 1; foreach $j (@LibCheckList) { if ( $j =~ m/^$libName$/ ) { $count++; } if ( $count > 1 ) { Error("Detected multiple references of lib [$libName] in lib list, check item [$sfile]."); } } # we will check to see if the file exists. # if ( -f "$m_srcFileLocation" ) { # now we need to copy the file. # we also want to create a generically named copy # of the library. ie: # libraryP.nn.nn.nn.dll -> library.dll, libraryP.dll # libraryP.so.nn.nn.nn -> library.so, libraryP.so # my ($gName) = $sfile; my ($nVerName) = $sfile; $gName = removeBuildTypeFromItemName($sfile); $gName = removeVersionNumberFromItemName($gName); $nVerName = removeVersionNumberFromItemName($sfile); if(File::Copy::copy("$m_srcFileLocation", "$m_dstFileLocation")) { Verbose("Copied Lib [$sfile] to [$m_dstFileLocation] ..."); $foundFileFlag = "true"; if ( $links && ( "x$PkgPatchID" eq "x" || "$MachType" eq "win32") ) { # normal build or if we are building win32 we want generic names # we want to create a copy of our target using # the generic name (no version number) if ( $sfile ne $nVerName ) { createGenericCopy("$sfile", "$m_srcFileLocation", "$nVerName", "$targetValue"); } # and another copy with no build type or version number. if ( $sfile ne $gName ) { # because this link doesn't have a P/D # differentiator, we can only have one, so # do this for the $BuildType file, but not any # $AlternateBuildType files if ( (!$installProdAndDebug) || ( $sfile =~ /$BuildType\./ ) ) { createGenericCopy("$sfile", "$m_srcFileLocation", "$gName", "$targetValue"); } } } # lets add this lib to our check list for next time. # push @LibCheckList, $libName; # no need to go further, implies we found the file! # last; } else { # here found the file but we had some trouble # Error("Failed to copy lib [$m_srcFileLocation]: $!"); } } # else have not found the file yet! } } # if we do not find the file at all we need to inform # the user. # if ( "$foundFileFlag" eq "false" && $ExcludedFlag eq "false" ) { Error("Dpkg_archive lib file [$sfile] does not exist or is not in correct directory structure."); } } return 1; } #------------------------------------------------------------------------------ sub installPkgAddConfigFile # # Description: # This sub-routine is used to install a package config file from a supplied # source location to a predefined destination location that is based on # the build type. # # The sub routine also updates to the prototype file with an appropriate # entry for the associated file. # Inputs: # sDirTag - Source directory tag # Or --Package=name,subdir # Or --Interface=subdir # sfile - Source File Name [Mandatory] # tfile - Not sure. Used in the prototype file. # Suggest using the same name as sfile # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 3 ) { Error("Incorrect number of params passed to " . "installPkgAddConfigFile() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("installPkgAddConfigFile() not supported on this machine type."); return 1; } my ($sDirTag, $sfile, $tfile) = @_; # we must have a filename. # unless ( $sfile ) { Error("Source filename not supplied. Check deploy config."); } # lets check to see if the local src dir tag exists # if does not the process with log an error. # my ($sDirValue) = getLocalDirValue("$sDirTag", "A"); # lets check to see if the source file exists # if ( ! -f "$sDirValue/$sfile" ) { Error("Failed to find local source file [$sDirValue/$sfile]."); } if ( ! -f "$ProtoTypeFile" ) { Error("Prototype file [$ProtoTypeFile] does not exist.", "Ensure createPrototypeFile() function has been called before executing installPkgAddConfigFile() function.", "Check deploy config."); } # lets determine which prototype file we are going to # use my ($dFileName); $dFileName = "$PkgBaseDir/$sfile"; # lets copy the file # if(File::Copy::copy("$sDirValue/$sfile", "$dFileName")) { Verbose("Copied [$sfile] to [$dFileName] ..."); } else { Error("Failed to copy local source file [$sDirValue/$sfile]: $!"); } # now we need to update the prototype file # local *FILE; open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); printf FILE ("i $tfile=$sfile\n"); close (FILE); return 1; } #------------------------------------------------------------------------------ sub installPkgAddSystemClassFile # # Description: # This sub-routine is used to install a package system class file from a supplied # source location to a predefined destination location the class type is also # supplied and must be sed, awk, build or preserve # # The sub routine also updates to the prototype file with an appropriate # entry for the associated file. # # If it has any problems it will log an error and stop processing. # # Inputs: # sDirTag - Source directory tag # Or --Package=name,subdir # Or --Interface=subdir # sfile - Source File Name [Mandatory] # tfile - Not sure. Used in the prototype file. # Suggest using the same name as sfile # class - Class Name #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 4 ) { Error("Incorrect number of params passed to " . "installPkgAddConfigFile() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("installPkgAddConfigFile() not supported on this machine type."); return 1; } my ($sDirTag, $sfile, $tfile, $class) = @_; if ( $class ne "sed" && $class ne "build" && $class ne "awk" && $class ne "preserve" ) { Error("Class Name for System Class File can only be one of sed, build, awk or preserve"); } # we must have a filename. # if ( "x$sfile" eq "x" ) { Error("Source filename not supplied. Check deploy config."); } # lets check to see if the local src dir tag exists # if does not the process with log an error. # my ($sDirValue) = getLocalDirValue("$sDirTag", "A"); # lets check to see if the source file exists # if ( ! -f "$sDirValue/$sfile" ) { Error("Failed to find local source file [$sDirValue/$sfile]."); } if ( ! -f "$ProtoTypeFile" ) { Error("Prototype file [$ProtoTypeFile] does not exist.", "Ensure createPrototypeFile() function has been called before executing installPkgAddConfigFile() function.", "Check deploy config."); } # lets determine which prototype file we are going to # use my ($dFileName); $dFileName = "$PkgBaseDir/$sfile"; # lets copy the file # if(File::Copy::copy("$sDirValue/$sfile", "$dFileName")) { Verbose("Copied [$sfile] to [$dFileName] ..."); } else { Error("Failed to copy local source file [$sDirValue/$sfile]: $!"); } # now we need to update the prototype file # local *FILE; open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); printf FILE ("e $class $tfile=$sfile ? ? ?\n"); close (FILE); return 1; } #------------------------------------------------------------------------------ sub updatePrototypeFileAddItem # # Description: # This sub-routine is used to update the prototype file with an # extra package add item. Here we pre-pend the ERGAFC_BASEDIR to the # destination item. # # The only item type we support at this stage are "s" and "f" types. # # You also need to supply the source tag, destination tag, user id, group id # and permissions associated to this item. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 6 ) { Error("Incorrect number of params passed to " . "updatePrototypeFileAddItem() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("updatePrototypeFileAddItem() not supported on this machine type."); return 1; } my ($sTag, $dTag, $perms, $uid, $gid, $type) = @_; # lets determine which prototype file we are going to # use my ($protoTypeFile); $protoTypeFile = "$ProtoTypeFile"; # lets check the valid types $type = uc($type); if ( "$type" !~ /S/ ) { Error("Invalid type field supplied in updatePrototypeFileAddItem(). Check deploy config."); } # now we need to update the prototype file # local *FILE; open ( FILE, ">> $protoTypeFile") or Error("Failed to open file [$protoTypeFile]."); my($m_Str)=""; if ( "$type" eq "S" ) { $m_Str = "s none $sTag=$ERGAFC_BASEDIR/$dTag $perms $uid $gid"; Verbose("Updated prototype file with entry [$m_Str]"); } else { $m_Str = "f none $sTag=$ERGAFC_BASEDIR/$dTag $perms $uid $gid"; Verbose("Updated prototype file with entry [$m_Str]"); } printf FILE ("$m_Str\n"); close (FILE); return 1; } #------------------------------------------------------------------------------ sub updatePrototypeFileAddItem2 # # Description: # This sub-routine is used to update the prototype file with an # extra package add item. Here we do not pre-append the # ERGAFC_BASEDIR to the destination item. # # The only item type we support at this stage are "s", "i" and "e" types. # # You also need to supply the source tag, destination tag, user id, group id # and permissions associated to this item. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 6 && ($#_+1) != 7 ) { Error("Incorrect number of params passed to " . "updatePrototypeFileAddItem2() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("updatePrototypeFileAddItem2() not supported on this machine type."); return 1; } # class must be last as it is optional my ($sTag, $dTag, $perms, $uid, $gid, $type, $class) = @_; $class = "none" if ( ($#_+1) == 6 ); # lets determine which prototype file we are going to # use my ($protoTypeFile); $protoTypeFile = "$ProtoTypeFile"; # lets check the valid types $type = uc($type); if ( "$type" !~ /S/ && "$type" !~ /I/ && "$type" !~ /E/ ) { Error("Invalid type field supplied in updatePrototypeFileAddItem2(). Check deploy config."); } # now we need to update the prototype file # local *FILE; open ( FILE, ">> $protoTypeFile") or Error("Failed to open file [$protoTypeFile]."); my($m_Str)=""; if ( "$type" eq "S" ) { $m_Str = "s $class $sTag=$dTag $perms $uid $gid"; Verbose("Updated prototype file with entry [$m_Str]"); } elsif ( "$type" eq "E" ) { $m_Str = "e $class $sTag=$dTag $perms $uid $gid"; Verbose("Updated prototype file with entry [$m_Str]"); } else { $m_Str = "i $sTag=$dTag"; Verbose("Updated prototype file with entry [$m_Str]"); } printf FILE ("$m_Str\n"); close (FILE); return 1; } #------------------------------------------------------------------------------ sub addPath2Prototype # # Description: # This sub-routine is used to add directory entries to the prototype file # to make sure the supplied path exists in the prototype file # #------------------------------------------------------------------------------ { # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("addPath2Prototype() not supported on this machine type."); return 1; } # class must be last as it is optional my ($path, $perms, $uid, $gid, $class) = @_; # set defaults if not supplied $perms = "?" if ( ($#_+1) < 2 ); $uid = "?" if ( ($#_+1) < 3 ); $gid = "?" if ( ($#_+1) < 4 ); $class = "none" if ( ($#_+1) < 5 ); Information("addPathToPrototype adding path [$path $perms $uid $gid $class]"); # lets determine which prototype file we are going to # use my ($protoTypeFile); $protoTypeFile = "$ProtoTypeFile"; # now we need to update the prototype file # local *FILE; open ( FILE, "+<$protoTypeFile") or Error("Failed to open file [$protoTypeFile]."); # set up has of all paths to be added my ( %pathDirs ); my ( $workPath ); my ( $i ); $workPath = "/" if ( $path =~ s|^/|| ); foreach $i ( split("/" , $path) ) { $workPath .= $i; $pathDirs{$workPath} = 1; $workPath .= "/"; } while ( ) { # lets get all the current dir entries and check for duplicates # class path mode owner group if ( /^d ([^ ]*) ([^ ]*) ([^ ]*) ([^ ]*) ([^ ]*)/ ) { # if this dir entry is defined in our paths to add we need to remove the entry if ( defined($pathDirs{$2}) ) { Warning("addPath2Prototype: Path [$2] already exists in prototype file"); delete($pathDirs{$2}); } } } my $protoLine; # now we write the remaining dirs in the hash foreach $i ( sort keys(%pathDirs) ) { $protoLine = sprintf("d %s %s %s %s %s", $class, $i, $perms, $uid, $gid); Verbose("addPath2Prototype: Adding Dir entry [$protoLine]"); printf FILE "$protoLine\n"; } close FILE; return 1; } #------------------------------------------------------------------------------ sub createAfcRcScriptLink # # Description: # This sub-routine is used to create links into /afc/rc.d for start & stop # scripts. # # INPUT: # Start prefix number (2 digit number) # Stop prefix Number (2 digit Number) # Full path to script to create link to. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 3 ) { Error("Incorrect number of params passed to " . "createAfcRcScriptLink() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createAfcRcScriptLink() not supported on this machine type."); return 1; } my ($startPrefix, $stopPrefix, $scriptPath) = @_; if ( $startPrefix ne "" ) { updatePrototypeFileAddItem2(sprintf("/afc/rc.d/S%02d%s", $startPrefix, $PkgName), $scriptPath, "0755", "root", "other", "S"); } if ( $stopPrefix ne "" ) { updatePrototypeFileAddItem2(sprintf("/afc/rc.d/K%02d%s", $stopPrefix, $PkgName), $scriptPath, "0755", "root", "other", "S"); } } #------------------------------------------------------------------------------ sub createAfcRcScriptLink2 # # Description: # This sub-routine is used to create links into the afc rc.d for start & stop # scripts. It differs from the original in that you pass a TargetDirType # parameter and the filename instead of a full path. It then creates a relative # link from $BASEDIR/rc.d to TargetBaseDir # # INPUT: # Start prefix number (2 digit number) # Stop prefix Number (2 digit Number) # Full path to script to create link to. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 4 ) { Error("Incorrect number of params passed to " . "createAfcRcScriptLink() function. " , "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createAfcRcScriptLink() not supported on this machine type."); return 1; } my ($startPrefix, $stopPrefix, $targetTag, $scriptPath) = @_; # lets check to see if the target tag exists if does not the process with log an error. my ($targetValue) = getTargetDstDirValue($targetTag, "R"); if ( $startPrefix ne "" ) { updatePrototypeFileAddItem2(sprintf("rc.d/S%02d%s", $startPrefix, $PkgName), "../$targetValue/$scriptPath", "0755", "root", "other", "S"); } if ( $stopPrefix ne "" ) { updatePrototypeFileAddItem2(sprintf("rc.d/K%02d%s", $stopPrefix, $PkgName), "../$targetValue/$scriptPath", "0755", "root", "other", "S"); } } #------------------------------------------------------------------------------ sub createGenericCopy # # Description: # This sub-routine is used to create a generic copy of a specific item. # # On sparc this will be a link, but on win32 it will be a file based on the # buildType. # # INPUT: # sName = src item name without path # sLoc = src item name including path # gName = generic item name # tDir = target dir # # RETURN: # 1 # #------------------------------------------------------------------------------ { my ($sName, $sLoc, $gName, $tDir) = @_; my ($cmd); my ($retVal); if ( "$MachType" eq "sparc" ) { # I want to cd into the tDir and then create the link. # only if an item of the same name does not already exist # if ( ! -f "$tDir/$gName" ) { $cmd = "cd $tDir; ln -s $sName $gName"; $retVal = system("$cmd"); if ( $retVal != 0 ) { Error("Failed to create generic link [$gName] to [$tDir/$sName]: $retVal"); } else { Verbose("Created generic link [$gName] to [$tDir/$sName] ..."); } } } else { # we only create a generic copy of the an item that matches # our build type. (i.e. if we are building a debug package then # only the debug items shall be considered. # if ( "$BuildType" eq "D" ) { if ( $sName !~ /D\./ ) { # this item is not a debug one. return 1; } } else { # this is prod build if ( $sName !~ /P\./ ) { # this item is not a prod one. return 1; } } # we have a match, lets create the copy. # if(File::Copy::copy("$sLoc", "$tDir/$gName")) { Verbose("Created generic lib copy [$tDir/$gName]..."); } else { Error("Failed to create generic lib copy [$gName] from [$sLoc]: $!"); } } return 1; } #------------------------------------------------------------------------------ sub removeVersionNumberFromItemName # # Description: # This sub-routine is used to remove the version number from the item name. # i.e. myFile.so.1.2.3 ==> myFile.so # # INPUT: # item name # # RETURN: # new item name. # #------------------------------------------------------------------------------ { my ($file) = @_; my ($nfile) = $file; if ( "$MachType" eq "sparc" ) { $nfile =~ s/\.so.*$/\.so/; } else { $nfile =~ s/\.[0-9]+\.[0-9]+.*dll$/\.dll/; } return "$nfile"; } #------------------------------------------------------------------------------ sub excludeItemFromBuild # # Description: # This sub-routine is used to determine is a item is to be included in # a build based on the current build type and the extension # it SHOULD HAVE!. # # i.e. debug files will be tagged with *D.* # prod file will be tagged with *P.* # # if the item does not have a *D.* or a *P.* we included it by default. # # INPUT: # filename # # RETURN: # 1 - exclude # 0 - include # #------------------------------------------------------------------------------ { my ($file) = @_; # we only want to deliver if ( "$MachType" eq "win32" ) { # we have to include it by default. return 0; } ####################################################### ####################################################### ####################################################### # Third party packages do not adhere to the *D.* *P.* # conventions of debug and production builds. # # Hopefully we won't have to many of these, only found # one so far. # ####################################################### ####################################################### ####################################################### if ( $file =~ /libTAO_BiDirGIOP\.so/ ) { return 0; } if ( $file !~ /D\./ && $file !~ /P\./ ) { # we have to include it by default. return 0; } # we only want to deliver if ( "$BuildType" eq "D" ) { if ( $file !~ /D\./ ) { # we do not want this file for this build type. return 1; } else { return 0; } } else { if ( $file !~ /P\./ ) { # we do not want this file for this build type. return 1; } else { return 0; } } return 1; } #------------------------------------------------------------------------------ sub installAllDpkgArchiveBinFiles # # Description: # This sub-routine is used to install all bin files from the # dpkg_archive into the defined install area. # # It assumes based on the build type where the src files will be located. # # If it has any problems it will log an error and stop processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "installAllDpkgArchiveBinFiles() function. " , "Check deploy config."); } my ($targetTag) = @_; # lets check to see if the target tag exists # if does not the process with log an error. # my ($targetValue) = getTargetDstDirValue($targetTag, "A"); # ok we have a valid dst value we now need to get a hold of all the # lib files for this buildtype # my ($i); my ($m_DpkgBinDir); foreach $i (@{$DpkgBinDirList{'_ALL_'}}) { $m_DpkgBinDir = "$DpkgBinDir/$i"; if ( ! -d $m_DpkgBinDir ) { Verbose("Directory [$m_DpkgBinDir] not found."); next; } local *DIR; opendir(DIR, $m_DpkgBinDir) or Error("can't opendir $m_DpkgBinDir : $!"); my ($file); while (defined($file = readdir(DIR))) { if ( $file !~ /^\.$/ && # we do not want the . and .. entries. $file !~ /^\.\.$/ && $file !~ /\.pdb$/ ) { my ($m_fLoc) = "$m_DpkgBinDir/$file"; if(File::Copy::copy("$m_fLoc", "$targetValue")) { Verbose("Copied [$file] to [$targetValue] ..."); } else { Error("Failed to copy bin [$m_fLoc]: $!"); } } } closedir(DIR); } return 1; } #------------------------------------------------------------------------------ sub rmDirectory # # Description: # This sub-routine is used to remove an entire directory tree. # # It recurses from a starting point removing each item and if it # finds a dir it recurses into that dir cleaning it as well. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to rmDirectory() function."); } my ($startingPoint) = @_; return 0 unless ( -d $startingPoint ); Verbose("Recursively removing Directory tree [$startingPoint]"); # # Use the rmtree function # It works better than glob when given a filepath with spaces # rmtree($startingPoint, IsVerbose(1), 1); Error("Failed to remove dir [$startingPoint] : $!") if (-d $startingPoint); return 1; } #------------------------------------------------------------------------------ sub CreateTargetDirStructure # # Description: # This sub-routine create the target stucture based on what the user has # previously defined in the %TargetDstDirStructure hash array # # It will also clean the contents of this location prior to creation. # # In this function we also check to see if all the LocalSrcDirStructure # directories exist. We warn if they do not. # #------------------------------------------------------------------------------ { Information("Cleaning any previous target file items..."); # Clean out PkgBaseDir # This is the directory in which the final package image will be assembled # Recreate the directory. Ensure that it does not have setgid on the directory # as this will affect all the subdirectories that are created and will # propergate into the target package. # rmDirectory( $PkgBaseDir ); make_directory( $PkgDir, 0777, "Create target base dir"); # lets create. # Information ("Creating target directory structure..."); my $dirRoot = ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir; make_directory( $dirRoot, 0777, "Create target dir"); foreach my $i ( sort {$a cmp $b} values %TargetDstDirStructure ) { make_directory("$dirRoot/$i", 0777); } # # Populate the target with InstallShield specific files # populateInstallShieldFiles(); # done. return 1; } #------------------------------------------------------------------------------- # Function : detectInstallShieldProject # # Description : Detect the presence of an InstallShield project # # Inputs : None # # Returns : Nothing # sub detectInstallShieldProject { # Only available on some platforms # return unless ( "$MachType" eq "win32" || "$MachType" eq "WinCE" ); my $m_ishieldDir; my $m_ishieldProjFile; my $m_ishieldRoot; # # Patches are different # if ( "x$PkgPatchNum" ne "x" ) { # patch build. $m_ishieldProjFile = "p${PkgName}.ism"; $m_ishieldDir = "p${PkgName}"; } else { # normal build. $m_ishieldProjFile = "${PkgName}.ism"; $m_ishieldDir = "${PkgName}"; } # # Expect the project file in one of several well known locations # Root of package # Current directory # if ( -f "$RootDir/$m_ishieldProjFile" ) { $m_ishieldRoot = $RootDir; } elsif ( -f "$CurrentDir/$m_ishieldProjFile" ) { $m_ishieldRoot = $CurrentDir; } else { return; } # Setup InstallShield definitions # $ISHIELD_ROOT = $m_ishieldRoot; $ISHIELD_PROJECTDIR = $m_ishieldRoot . '/' . $m_ishieldDir; $ISHIELD_PROJECT = $m_ishieldRoot . '/' . $m_ishieldProjFile; return; } #------------------------------------------------------------------------------- # Function : populateInstallShieldFiles # # Description : Copy in InstallShield Specific files # # Inputs : Nothing # # Returns : Nothing # sub populateInstallShieldFiles { # lets determine if we have a InstallShield config dir # if ( $ISHIELD_ROOT ) { if ( ! -d $ISHIELD_PROJECTDIR ) { Error ("Local InstallShield config dir [$ISHIELD_PROJECTDIR] does not exist.", "Please create before continuing."); } # we populate the ishield config dir with the ishieldlib files # Verbose("Installing Standard ishieldlib files from [$PKG_UTIL_DIR] to [$ISHIELD_PROJECTDIR]"); foreach my $i ( @PKG_ISHIELD_FILES ) { # first we remove the file (as previously it install read-only). unlink("$ISHIELD_PROJECTDIR/$i"); if( File::Copy::copy("$PKG_UTIL_DIR/$i", "$ISHIELD_PROJECTDIR") ) { Verbose("Copied [$PKG_UTIL_DIR/$i] to [$ISHIELD_PROJECTDIR] ..."); } else { Error("Failed to copy info file [$PKG_UTIL_DIR/$i] to [$ISHIELD_PROJECTDIR] : $!"); } } # we also want to deliver the patch rule files # if this build is a patch build. # if ( "x$PkgPatchNum" ne "x" ) { Verbose("Installing Patch ishieldlib files from [$PKG_UTIL_DIR] to [$ISHIELD_PROJECTDIR]"); foreach my $i ( @PATCH_ISHIELD_FILES ) { # first we remove the file (as previously it install read-only). unlink("$ISHIELD_PROJECTDIR/$i"); if( File::Copy::copy("$PKG_UTIL_DIR/$i", "$ISHIELD_PROJECTDIR") ) { Verbose("Copied [$PKG_UTIL_DIR/$i] to [$ISHIELD_PROJECTDIR] ..."); } else { Error("Failed to copy info file [$PKG_UTIL_DIR/$i] to [$ISHIELD_PROJECTDIR] : $!"); } } } # we also want to deliver the islib images to be # used by this project, we assume the image has a project # acronym prefix, and if not found we just WARN the user # # we assume our source dir is the interface/etc dir and our # dst dir is the PkgBaseDir # Verbose("Installing ishield image files from [$DpkgEtcDir] to [$ISHIELD_PROJECTDIR]"); foreach my $i ( @PKG_ISHIELD_IMG_FILES ) { my $m_islibImgFile = "$DpkgEtcDir/$ProjectAcronym" . "_" . $i; if ( -f "$m_islibImgFile" ) { if( File::Copy::copy("$m_islibImgFile", "$PkgBaseDir") ) { Verbose("Copied [$m_islibImgFile] to [$PkgBaseDir] ..."); } else { Error("Failed to copy info file [$m_islibImgFile] to " . "[$PkgBaseDir] : $!"); } } else { # we shall check for the MASS items, if the exist we copy them # over. Here we assume the 'mas' acronymn is correct. # my $m_islibImgFile = "$DpkgEtcDir/mas" . "_" . $i; if ( -f "$m_islibImgFile" ) { if( File::Copy::copy("$m_islibImgFile", "$PkgBaseDir") ) { Verbose("Copied [$m_islibImgFile] to [$PkgBaseDir] ..."); } else { Error("Failed to copy info file [$m_islibImgFile] to " . "[$PkgBaseDir] : $!"); } } else { Warning("Failed to locate ishieldlib image [xxx_$i], no image copied, " . "check depolylib config."); } } } } } #------------------------------------------------------------------------------ sub generateIShieldIncludeFile () # # Description: # This subroutine is used to generate a definition include file # that is used during IShield builds. # # The output location of the file is the IShieldProjDir. # #------------------------------------------------------------------------------ { my ($outFile); # this is only relavent for win32 builds. if ( "$MachType" eq "sparc" ) { return 1; } # # Ignore directive if the IS project was not found # unless( $ISHIELD_PROJECTDIR ) { Warning ("generateIShieldIncludeFile: Ignored as no InstallShield project was found"); return 1 } $outFile = "$ISHIELD_PROJECTDIR/$ISHIELD_PKGDEF_FILE"; # lets open the file. # local *FILE; open ( FILE, "> $outFile") or Error("Failed to open file [$outFile]."); # lets populate the pkgdef file. printf FILE ("// This is an automatically generated include file.\n"); printf FILE ("// Please do not modify, and please do not check into ClearCase.\n"); printf FILE ("//\n"); printf FILE ("#define PKG_NAME \"$PkgName\"\n"); printf FILE ("#define PKG_NAMELONG \"$PkgNameLong\"\n"); printf FILE ("#define PKG_VERSION \"$PkgVersion\"\n"); printf FILE ("#define PKG_BUILDNUM \"$PkgBuildNum\"\n"); printf FILE ("#define PKG_PROJACRONYM \"$ProjectAcronym\"\n"); printf FILE ("#define PKG_DESC \"$PkgDesc\"\n"); # if this build is a patch build. # if ( "x$PkgPatchNum" ne "x" ) { printf FILE ("#define PATCH_NAME \"$PkgPatchName\"\n"); printf FILE ("#define PATCH_NUM \"$PkgPatchNum\"\n"); printf FILE ("#define PATCH_ID \"$PkgPatchID\"\n"); } else { printf FILE ("#define PATCH_NAME \"\"\n"); printf FILE ("#define PATCH_NUM \"\"\n"); printf FILE ("#define PATCH_ID \"\"\n"); } # lets close the file close FILE; # done. return 1; } #------------------------------------------------------------------------------ sub ValidateLocalSrcDirStructure # # Description: # This sub-routine is used to check the existence the local dir # configuration items, these are stored in # %LocalSrcDirStructure. # #------------------------------------------------------------------------------ { # lets check the configured local direcotry structure # my ($i); foreach $i ( values %LocalSrcDirStructure ) { my ($m_Dir) = "$SrcDir/$i"; if ( ! -d "$m_Dir" ) { Warning ("Local src dir [$m_Dir] does not exist."); } } return 1; } #------------------------------------------------------------------------------ sub getLocalDirValue # # Description: # This sub-routine is used to return the local dir value from # %LocalSrcDirStructure based on providing the # associated key. # # # Input: # m_key - A symbolic directory name to be found in the # LocalSrcDirStructure # # A Package Name of the form # --Package=PackageName,subdir # # A directory within the interface directory # --Interface=subdir # # This form is only valid for an ABS address # # m_type - "A" Absolute address # else Relative address # # If the value does not exist then it will return an error # and terminate processing. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "getLocalDirValue() function."); } my ($m_key, $m_type) = @_; # # Determine the type of lookup # if ( $m_key =~ m~^--Interface=(.*)~ ) { Error("Locating Interface directory must be used in conjunction with an Absolute path") unless ( $m_type eq 'A' ); my $SubDir = $1; my $Dir = "$InterfaceDir/$SubDir"; Error ("Interface subdirectory not found: $SubDir" ) unless ( -d $Dir ); return $Dir; } if ( $m_key =~ m~^--Package=(.*)~ ) { Error("Locating local source directory must be used in conjunction with an Absolute path") unless ( $m_type eq 'A' ); # # Locate directory within a package # my ($PkgName, $PkgSubDir) = split /[\/,]/, $1, 2; Error ("--Package requres a package name and a subdirectory") unless ( $PkgName && $PkgSubDir ); my $PkgDir = LocatePackageBase( "getLocalDirValue", $PkgName, $PkgSubDir ); return $PkgDir; } # # Locate the directory within the LocalSrcDirStructure # This is a symbolic reference to a local directory # if (exists $LocalSrcDirStructure{$m_key} ) { if ( "$m_type" eq "A" ) { return "$SrcDir/$LocalSrcDirStructure{$m_key}"; } else { return "$LocalSrcDirStructure{$m_key}"; } } else { Error("Local src tag [$m_key] does not exist in " . "LocalSrcDirStructure. " , "Check deploy configuration."); } return 1; } #------------------------------------------------------------------------------ sub getTargetDstDirValue # # Description: # This sub-routine is used to return the target dest dir value from # %TargetDstDirStructure based on providing the # associated key. # # If the value does not exist then it will return an error # and terminate processing. # # Inputs: $m_key Symbolic name for target directory # $m_type Type : A - Absolute # R - Relative # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "getTargetDstDirValue() function."); } my ($m_key, $m_type) = @_; my $tdir = ($TargetBaseDir ne ".") ? "$TargetBaseDir/" : ""; # # Look up the users tag conversion hash # if ( exists $TargetDstDirStructure{$m_key} ) { $tdir .= $TargetDstDirStructure{$m_key}; } else { Error("Target destination dir tag [$m_key] does not exist in " . "TargetDstDirStructure. " , "Check deploy configuration."); } # # If an absolute path is required than add the PkgBaseDir # otherwise the user must be requesting a relative path. # if ( "$m_type" eq "A" ) { $tdir = "$PkgBaseDir/$tdir"; } elsif ( "$m_type" eq "R" ) { } else { Error("getTargetDstDirValue: Bad call. Unknown type: $m_type"); } return $tdir; } #------------------------------------------------------------------------------ sub createPatch # # Description: # This sub-routine is used to create a solaris patch. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 0 ) { Error("Incorrect number of params passed to " . "createPatch() function.", "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createPatch() not supported on this machine type."); return 1; } # lets just check to see if we can execute this function on # for this build. # if ( "x$PkgPatchNum" eq "x" ) { Warning("createPatch() can only be called during a PATCH build."); return 1; } # we need to create the patch directory that contains # Information("Creating patch ..."); my ( $m_pkgmkCmd ); my ( $m_pkgtransCmd ); $m_pkgmkCmd = "pkgmk -o " . "-f $PkgBaseDir/prototype " . "-d $PkgBaseDir"; # lets execute the package commands. my ($retVal); $retVal = system("$m_pkgmkCmd"); if ( $retVal != 0 ) { Error("Failed to complete command [$m_pkgmkCmd]."); } # we need to generate a README file to help during installation # generatePatchREADME(); my ($m_Cmd) = ""; my ($m_tmpDir) = "$PkgPatchTmpDir/$PkgPatchID"; Information("Creating staging area of patch..."); $m_Cmd = "cd $PkgBaseDir && mkdir -p $m_tmpDir;"; system($m_Cmd); Information("Copying patch contents to staging area of patch..."); $m_Cmd = "cd $PkgBaseDir && cp -r $PkgName $m_tmpDir;"; system($m_Cmd); # we need to copy the patch install utility files from # their resting place. # my ($i); foreach $i ( @PATCH_UTIL_FILES ) { if( File::Copy::copy("$PATCH_UTIL_DIR/$i", "$PkgPatchTmpDir") ) { Verbose("Copied [$PATCH_UTIL_DIR/$i] to [$PkgPatchTmpDir] ..."); system("chmod 0755 $PkgPatchTmpDir/$i"); } else { Error("Failed to copy info file [$PATCH_UTIL_DIR/$i] to [$PkgPatchTmpDir] : $!"); } } # Lets put the readme in place # if( File::Copy::copy("$PkgPatchReadme", "$PkgPatchTmpDir") ) { Verbose("Copied [$PkgPatchReadme] to [$PkgPatchTmpDir] ..."); } else { Error("Failed to copy info file [$PkgPatchReadme] to [$PkgPatchTmpDir] : $!"); } Information("Copying patch contents to staging area of patch..."); $m_Cmd = "cd $PkgBaseDir && cp -r $PkgName $m_tmpDir;"; system($m_Cmd); my ($m_oFile) = "$PkgPatchID-$ProjectAcronym\.tgz"; Information("Creating a gzip'd compressed tar (.tgz) output file [$m_oFile]..."); my ($base) = File::Basename::basename($PkgPatchTmpDir); $m_Cmd = "cd $PkgBaseDir && tar cvf - $base | gzip > $m_oFile"; system($m_Cmd); return 1; } #------------------------------------------------------------------------------ sub generatePatchREADME # # This function is used to generate a README text file to help the user # duing the patch installation. # #------------------------------------------------------------------------------ { local *FILE; open ( FILE, "> $PkgPatchReadme") or Error("Failed to open file [$PkgPatchReadme]."); printf FILE ("This is a patch for $PkgName $PkgVersion\n"); printf FILE ("---------------------------------------------------------------\n"); printf FILE ("\n"); printf FILE ("Installing patch (as the 'root' user) :\n"); printf FILE ("---------------------------------------------------------------\n"); printf FILE ("./installpatch $PkgPatchID\n"); printf FILE ("\n"); printf FILE ("Backing Out patch:\n"); printf FILE ("---------------------------------------------------------------\n"); printf FILE ("./backoutpatch $PkgPatchID\n"); printf FILE ("\n"); printf FILE ("Patch contents of $PkgPatchID\n"); printf FILE ("---------------------------------------------------------------\n"); close FILE; # now we need to get the contents of the patch we are creating. # File::Find::find(\&getPatchContents, ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir ); return 1; } #------------------------------------------------------------------------------ sub getPatchContents # # This sub-routine adds an entry into the readme file for each # item in the patch delivery tree. # #------------------------------------------------------------------------------ { my($file)= "$File::Find::name"; my($base)= File::Basename::basename($file); # we get the absolute path from the find, but we only require # a relative path from the starting dir. # so our start dir. my ($m_sfile) = $file; $file =~ s/$PkgBaseDir//; open ( FILE, ">> $PkgPatchReadme") or Error("Failed to open file [$deplylib::PkgPatchReadme]."); # lets populate the prototype file. printf FILE ("* $file\n"); close (FILE); } #------------------------------------------------------------------------------ sub createPackage # # Description: # This sub-routine is used to create a package. # The type of package is machine specific. The subroutine will invoke a # machine specfic function to do the real work. # #------------------------------------------------------------------------------ { Information("createPackage"); # lets just check to see if we can execute this function on # this machine. # my $createRoutine = 'createPackage_' . $MachType; if ( exists &$createRoutine ) { # lets just check to see if we can execute this function on # for this build. # if ( $PkgPatchNum ) { Warning("createPackage() can only be called during a RELEASE build."); return 1; } # # Ensure the Release directory is present # make_directory( $ReleaseDir, 0777 ); # Ensure that the package descriptor is transferred # my ($m_copydesc) = "cp $SrcDir/descpkg $ReleaseDir"; system($m_copydesc); # Invoke the machine specific package builder by name # Need to relax strictness. Yes we do know what we are doing here # no strict "refs"; &$createRoutine( @_ ) || Error("Unspecified error building package"); use strict "refs"; } else { Verbose("createPackage() not supported on this machine type: $MachType."); } return 1; } #------------------------------------------------------------------------------ sub createPackage_sparc # # Description: # This sub-routine is used to create a package. # The type of package is machine specific. The subroutine will invoke a # machine specfic function to do the real work. # #------------------------------------------------------------------------------ { Verbose("createPackage_sparc"); # we need to copy the package utility files from # their resting place. # foreach my $i ( @PKG_UTIL_FILES ) { if( File::Copy::copy("$PKG_UTIL_DIR/$i", "$PkgBaseDir") ) { Verbose("Copied [$PKG_UTIL_DIR/$i] to [$PkgBaseDir] ..."); updatePrototypeFileAddItem2("$i", "$i", "", "", "", "I"); system("chmod 0755 $PkgBaseDir/$i"); } else { Error("Failed to copy info file [$PKG_UTIL_DIR/$i] to [$PkgBaseDir] : $!"); } } # # Scan the install 'image' looking for files and directories that have a 'space' in the name # These are not handled by the pkgmk utility, so it is best to create a nice error message now. # my $search = LocateFiles->new( recurse => 1, dirs_too => 1 ); $search->filter_in_re('\s'); my @m_nfiles = $search->search($PkgBaseDir); if ( @m_nfiles ) { Error ("Pathnames containing a space cannot be packaged under Solaris", "The following paths contain a space", @m_nfiles ); } my ( $m_pkgmkCmd ); my ( $m_pkgtransCmd ); $m_pkgmkCmd = "pkgmk -o " . "-f $PkgBaseDir/prototype " . "-d $PkgBaseDir " . "-r $PkgBaseDir"; $m_pkgtransCmd = "pkgtrans -o " . "-s $PkgBaseDir " . "$PkgOutputFile " . "$PkgName"; # lets execute the package commands. my ($retVal); $retVal = system("$m_pkgmkCmd"); if ( $retVal != 0 ) { Error("Failed to complete command [$m_pkgmkCmd]."); } $retVal = system("$m_pkgtransCmd"); system("$m_pkgtransCmd"); if ( $retVal != 0 ) { Error("Failed to complete command [$m_pkgtransCmd]."); } # lets compress the output to save some space. # Information("Compressing $PkgOutputFile"); my ($m_compressCmd) = "cd $PkgBaseDir; gzip $PkgOutputFile; mv ${PkgOutputFile}.gz $ReleaseDir"; system($m_compressCmd); return 1; } #------------------------------------------------------------------------------ sub createPackage_WinCE # # Description: # This sub-routine is used to create a package. # Really a win32 machine type, but for some reason, the MachType gets # stuffed around. Don't know why. # # Do have the option of creating a WinCE specific packager # #------------------------------------------------------------------------------ { Verbose("createPackage_WinCE"); createPackage_win32(@_); } #------------------------------------------------------------------------------ sub createPackage_win32 # # Description: # This sub-routine is used to create a package. # Invoke the isbuild.pl utility to build the install shield project # #------------------------------------------------------------------------------ { Verbose("createPackage_win32"); Error ("InstallShield project not found") unless ( $ISHIELD_PROJECT && -f $ISHIELD_PROJECT ); # # Process any options that may be present # Don't complain about args we don't understand. They may apply to other # platforms # my @user_options = (); foreach my $arg ( @_ ) { if ( $arg =~ m/^-nonameversion/ || $arg =~ m/^-nameversion/ ) { push @user_options, $arg; } elsif ( $arg =~ m/^-nocode/ || $arg =~ m/^-code/ ) { push @user_options, $arg; } elsif ( $arg =~ m/^-nomultiprod/ || $arg =~ m/^-multiprod/ ) { push @user_options, $arg; } elsif ( $arg =~ m/^-nomultirel/ || $arg =~ m/^-multirel/ ) { push @user_options, $arg; } else { Message ( "createPackage_win32: Unknown option: $_"); } } # # Locate MergeModules in external packages # These will be used by the InstallShield compiler # my @mm_dirs; my @mm_tld; my $tdir; # # Check for Merge Modules in the local directory # This must be a flat directory structure. ie: all files in the # subdirectory called MergeModule. # $tdir = "$RootDir/MergeModules"; push @mm_dirs, $tdir if ( -d $tdir ); Verbose ("Discovered MergeModules in: $tdir") if ( -d $tdir ); # # Check for Merge Modules in the Interface directory # This will be pulled in via a BuildPkgArchive # $tdir = "$InterfaceDir/MergeModules"; push @mm_tld, $tdir if ( -d $tdir ); Verbose ("Discovered MergeModules in: $tdir") if ( -d $tdir ); # # Check in LinkPkgArchive locations too for my $entry ( $BuildFileInfo->getBuildPkgRules() ) { next unless ( $entry->{'TYPE'} eq 'link' ); $tdir = $entry->{'ROOT'} . '/MergeModules'; push @mm_tld, $tdir if ( -d $tdir ); Verbose ("Discovered MergeModules in: $tdir") if ( -d $tdir ); } # # Expand the merge module subdirectory tree into # suitable paths: # Modules/i386 # Modules/i386/ # Objects # Merge Modules # foreach my $dir ( @mm_tld ) { $tdir = $dir . '/Modules/i386'; if ( -d $tdir ) { push @mm_dirs, $tdir; foreach my $file ( glob( "$tdir/*" )) { next unless ( -d $file ); push @mm_dirs, $file; } } $tdir = $dir . '/Objects'; push @mm_dirs, $tdir if ( -d $tdir ); $tdir = $dir . '/Merge Modules'; push @mm_dirs, $tdir if ( -d $tdir ); } # # Locate the program # It will be in a location addressed by the @INC path # my $prog_found; my $prog; foreach my $dir ( @INC ) { $prog = $dir . '/isbuild.pl'; next unless ( -f $prog ); $prog_found = 1; last; } # # Note: Use $RootDir for the ISBUILD workdir # Would like t use interface, but it makes # the pathname longer and some MergeModules can # be extracted. ISBUILD appears to have a path length limit of # about 204 character. We need all we can get. # Error("isbuild.pl not found") unless $prog_found; Verbose("isbuild: $prog"); my $rv = system ( $ENV{GBE_PERL}, $prog, "-project=$ISHIELD_PROJECT", "-version=$PkgVersionUser", "-out=$ReleaseDir", "-workdir=$RootDir", @user_options, map { "-mergemodule=$_" } @mm_dirs ); Error ("InstallShield Builder Error" ) if ( $rv ); return 1; } #------------------------------------------------------------------------------ sub createPrototypeFile # # Description: # This sub-routine is used to create the required package prototype file # from a known directory struture using the search path method. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "createPrototypeFile() function", "Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createPrototypeFile() not supported on this machine type."); return 1; } # lets take the passed in args. my ($uid, $gid) = @_; # we need to locate the prototype file if ( -f "$ProtoTypeFile" ) { unlink("$ProtoTypeFile"); Verbose("Removing prototype file [$ProtoTypeFile]."); } # lets open the prototype file. # local *FILE; open ( FILE, "> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); # lets populate the prototype file. printf FILE ("i pkginfo\n"); printf FILE ("!search"); close(FILE); # now we need to add entries for each directory we will # be installing File::Find::find( \&prototypeFind, ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir ); # lets populate the prototype file with a newline. open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); printf FILE ("\n"); close (FILE); # lets put the pre-deinfed generic entries into the # prototype file # if ( "x$PkgPatchNum" ne "x" ) { addPatchInfo2ProtoTypeFile(); } # we need to expand and complete the creation of the # prototype file # if Targetbasedir is "." the pkgproto will pick up the pkginfo and # prototype files so we need to remove them my ($m_cmd) = "pkgproto " . "$TargetBaseDir " . "| egrep -v \"($ProtoTypeFileName|$PkgInfoFileName)\"" . "| cut -f1-4 -d' ' | sed " . '"s/\$/ ' . "$uid $gid" . '/g"' . " >> $ProtoTypeFile"; my ($retVal) = system("cd $PkgBaseDir; $m_cmd"); if ( $retVal != 0 ) { Error("Failed to create prototype file [$ProtoTypeFile]."); } Information("Created prototype file [$ProtoTypeFile]."); return 1; } #------------------------------------------------------------------------------ sub prototypeFind # # Description: # This subroutine is used to locate all associated package dirs. # It also adds an entry into the prototype file for each dir. # #------------------------------------------------------------------------------ { my ($file) = $File::Find::name; # Our topdir will either be $PkgBaseDir or $PkgBaseDir/$TargetBaseDir (if there is a TargetBaseDir). # if we have PKgBaseDir only we dont want to include this in the search path, # if TargetBaseDir is defined we include it in the search paths if ( $file ne $PkgBaseDir && -d $file ) { # we get the absolute path from the find, but we only require a relative path from the starting dir. # So remove PkgBaseDir from path and include all dirs below it including TargetBaseDir if there is one $file =~ s|$PkgBaseDir/*||; open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); # lets populate the prototype file. printf FILE (" $file"); close (FILE); } } #------------------------------------------------------------------------------ sub addPatchInfo2ProtoTypeFile # # Description: # This sub-routine is used to add additonal genericinformation # used by the patch. # #------------------------------------------------------------------------------ { Information("Adding patch information files to patch build..."); # we need to determine whiich file we are dealing with my ($protoTypeFile); $protoTypeFile = "$ProtoTypeFile"; # lets open the prototype file. # local *FILE; open ( FILE, ">> $protoTypeFile") or Error("Failed to open file [$protoTypeFile]."); # we need to copy the install informational files from # their resting place. my ($i); foreach $i ( @PATCH_INFO_FILES ) { if( File::Copy::copy("$PATCH_UTIL_DIR/$i", "$PkgBaseDir") ) { Verbose("Copied [$PATCH_UTIL_DIR/$i] to [$PkgBaseDir] ..."); printf FILE ("i $i\n"); } else { Error("Failed to copy info file [$PATCH_UTIL_DIR/$i]: $!"); } } close FILE; return 1; } #------------------------------------------------------------------------------ sub useReplaceClass # # Description: # This sub-routine is used to add replace class to the classes list and # include the i.replace file in the PKG_INFO_FILES List # #------------------------------------------------------------------------------ { Information("useReplaceClass: Adding replace class to installer"); $PkgInfoClasses = $PkgInfoClasses . " " . "replace"; push(@PKG_UTIL_FILES, "i.replace"); } #------------------------------------------------------------------------------ sub addPkgInfoClasses # # Description: # This sub-routine is used to add new classes to the pkginfo CLASSES variable. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) == 0 ) { Error("Incorrect number of params passed to " . "createPkginfoFile() function", "Check deploy config."); } Information("addPkgInfoClasses() Adding classes \"" . join(" ", @_) . "\" to CLASSES List"); $PkgInfoClasses = $PkgInfoClasses . " " . join(" ", @_); } #------------------------------------------------------------------------------ sub addPkgInfoField # # Description: # This sub-routine is used to add new fields to already created pkginfo file # Acccepts any number of fields of format A=B as one string parameter. #------------------------------------------------------------------------------ { # lets just check to see if we can execute this function on this machine. if ( "$MachType" ne "sparc" ) { Verbose("addPkgInfoField() not supported on this machine type."); return 1; } # lets open the pkginfo file. local *FILE; open ( FILE, ">> $PkgInfoFile") or Error("Failed to open file [$PkgInfoFile]."); foreach my $i ( @_ ) { print FILE "$i\n"; } close FILE; return 1; } #------------------------------------------------------------------------------ sub updatePrototypeFileItemClass # # Description: # This subroutine is used to change the class of a file already in the prototype file # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 2 ) { Error("Incorrect number of params passed to " . "updatePrototypeFileItemClass() function. Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("updatePrototypeFileItemClass() not supported on this machine type."); return 1; } # lets setup the passed values. my ($m_item, $class) = @_; my ($tmpProtoTypeFile) = "/tmp/xx_prototypefile.$$"; # lets open the prototype file if it exists # open (PFILE, "< $ProtoTypeFile") or Error("Failed to open prototype file [$ProtoTypeFile]."); open (PFILETMP, "> $tmpProtoTypeFile") or Error("Failed to open tmp prototype file [$tmpProtoTypeFile]."); while ( ) { chomp; # The path section will normally contain "path [mode]" or path=path # The passed arg can be full path or can skip top level dirs # eg prototype can have line with path ergbpeod/etc/afcbp.ini # arg to match can be ergbpeod/etc/afcbp.ini, etc/afcbp.ini or afcbp.ini # therefore we need to match arg to the end of the path in line # so we append [= ] to arg s/^(\s*[bcdefilpsvx]\s*)[^\s]*(.*$)/$1$class$2/ if ( /$m_item[ =]/ ); printf PFILETMP ("$_\n"); } close PFILE; close PFILETMP; # now we need to copy the file. if(File::Copy::copy("$tmpProtoTypeFile", "$ProtoTypeFile")) { Verbose("Updated file $m_item to class $class"); unlink($tmpProtoTypeFile); } else { Error("Failed to copy lib [$tmpProtoTypeFile]: $!"); } return 1; } #------------------------------------------------------------------------------ sub setReplaceClassFiles # # Description: # This subroutine is used to change the class of a file already in the prototype file # #------------------------------------------------------------------------------ { # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("updatePrototypeFileItemClass() not supported on this machine type."); return 1; } Error("Must call useReplaceClass() before calling setReplaceClassFiles()") if ( $PkgInfoClasses !~ /replace/ ); my ($tmpProtoTypeFile) = "/tmp/xx_prototypefile.$$"; # lets open the prototype file if it exists # open (PFILE, "< $ProtoTypeFile") or Error("Failed to open prototype file [$ProtoTypeFile]."); open (PFILETMP, "> $tmpProtoTypeFile") or Error("Failed to open tmp prototype file [$tmpProtoTypeFile]."); my $line; while ( $line = ) { chomp $line; # The path section will normally contain "path [mode]" or path=path # The passed args can be full path or can skip top level dirs # eg prototype can have line with path ergbpeod/etc/afcbp.ini # args to match can be ergbpeod/etc/afcbp.ini, etc/afcbp.ini or afcbp.ini # therefore we need to match each arg to the end of the path in line # so we append [= ] to end of each arg $line =~ s/^(\s*[bcdefilpsvx]\s*)[^\s]*(.*$)/$1replace$2/ if ( scalar(grep { $line =~ /$_[ =]/ } @_) > 0 ); printf PFILETMP ("$line\n"); } close PFILE; close PFILETMP; # now we need to copy the file. if(File::Copy::copy("$tmpProtoTypeFile", "$ProtoTypeFile")) { Verbose("Updated prototype file entries to class replace"); unlink($tmpProtoTypeFile); } else { Error("Failed to copy lib [$tmpProtoTypeFile]: $!"); } return 1; } #------------------------------------------------------------------------------ sub createPkginfoFile # # Description: # This sub-routine is used to create the required package info. # Accepts any number of parameters, with each parameter taken as a literal # Field=Value string and inserted into the PkgInfo File #------------------------------------------------------------------------------ { # lets check to see if our description has been set if ( $PkgDesc eq "" ) { Error("Package description not set. " . "Use setPkgDescription('my package description') function."); } # lets check to see if our long name has been set if ( $PkgNameLong eq "" ) { Error("Package name not set. Use setPkgName('my package long name') function."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { generateIShieldIncludeFile(); return 1; } # we need to determine whiich file we are dealing with my ($pkginfoFile) = "$PkgInfoFile"; # we need to locate the pkginfo file if ( -f "$pkginfoFile" ) { unlink("$pkginfoFile"); Verbose("Removing pkginfo file [$pkginfoFile]."); } # lets open the pkginfo file. # local *FILE; open ( FILE, "> $pkginfoFile") or Error("Failed to open file [$pkginfoFile]."); # lets populate the pkginfo file. printf FILE ("PKG=$PkgName\n"); # here we deal with the new version number format # Error ("Internal: MachArch is not defined") unless ( $MachArch ); printf FILE ("NAME=$PkgNameLong\n"); printf FILE ("VERSION=$PkgVersion.$ProjectAcronym\n"); printf FILE ("ARCH=$MachArch\n"); printf FILE ("SUNW_ISA=$MachISA\n") if ( $MachISA ); printf FILE ("VENDOR=$VENDOR_DESC\n"); printf FILE ("DESC=$PkgDesc\n"); printf FILE ("CATEGORY=$CATEGORY_DESC\n"); printf FILE ("BASEDIR=$ERGAFC_BASEDIR\n"); printf FILE ("TARGETBASEDIR=$TargetBaseDir\n") unless ( $TargetBaseDir eq "." ); printf FILE ("CLASSES=$PkgInfoClasses\n"); foreach my $param ( @_ ) { printf FILE "$param\n"; } if ( "x$PkgPatchNum" ne "x" ) { my ($count)=1; my ($pRev)=""; printf FILE ("MAXINST=$MAXINST\n"); printf FILE ("SUNW_PATCHID=$PkgPatchID\n"); printf FILE ("SUNW_REQUIRES=\n"); printf FILE ("SUNW_INCOMPAT=\n"); $count=1; $pRev=""; printf FILE ("SUNW_OBSOLETES="); while ( $count < $PkgPatchNum ) { $pRev = sprintf ("%02s", $count); printf FILE ("$PkgPatchName" . "$PkgVersionStr" . "-" . "$pRev "); $count++; } printf FILE ("\n"); $count=1; $pRev=""; printf FILE ("PATCH_OBSOLETES="); while ( $count < $PkgPatchNum ) { $pRev = sprintf ("%02s", $count); printf FILE ("$PkgPatchName" . "$PkgVersionStr" . "-" . "$pRev "); $count++; } printf FILE ("\n"); } # now we will list the build dependencies so # we can refer to them online # my ($i); my ($m_Str); # printf FILE ("\n"); my ($count) = 1; foreach $i ( $BuildFileInfo->getDpkgArchiveList() ) { my $moduleInfo = $BuildFileInfo->getDpkgArchiveInfo($i); printf FILE ( "$moduleInfo->{type}\_$count=$i $moduleInfo->{version}"); # we shall print the project bit if we have one if ( $moduleInfo->{proj} ne "" ) { printf FILE ( "\.$moduleInfo->{proj}\n"); } else { printf FILE ("\n"); } $count++; } close FILE; # lets close the pkginfo file. close (FILE); Information("Created pkginfo file [$pkginfoFile]."); return 1; } #------------------------------------------------------------------------------ sub updatePrototypeFileItemOwner # # Description: # This sub-routine is used to change the ownership of a file item # in the prototype file. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 4 ) { Error("Incorrect number of params passed to " . "updatePrototypeFileItemOwner() function. Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("chmod() not supported on this machine type."); return 1; } # lets setup the passed values. my ($m_item, $m_ownPerms, $m_ownUser, $m_ownGroup) = @_; my ($tmpProtoTypeFile) = "/tmp/xx_prototypefile.$$"; # lets open the prototype file if it exists # open (PFILE, "< $ProtoTypeFile") or Error("Failed to open prototype file [$ProtoTypeFile]."); open (PFILETMP, "> $tmpProtoTypeFile") or Error("Failed to open tmp prototype file [$tmpProtoTypeFile]."); my ($inLine); while ( ) { $inLine = $_; chomp($inLine); if ( "$inLine" =~ /^f / && "$inLine" =~ /$m_item/ ) { my ($b1, $b2, $b3, $b4, $b5, $b6) = split (/ /, $inLine); printf PFILETMP ("$b1 $b2 $b3 $m_ownPerms $m_ownUser $m_ownGroup\n"); } else { printf PFILETMP ("$inLine\n"); } } close PFILE; close PFILETMP; # now we need to copy the file. if(File::Copy::copy("$tmpProtoTypeFile", "$ProtoTypeFile")) { Verbose("Copied [$tmpProtoTypeFile] to [$ProtoTypeFile] ..."); unlink($tmpProtoTypeFile); } else { Error("Failed to copy lib [$tmpProtoTypeFile]: $!"); } return 1; } #------------------------------------------------------------------------------ sub setPermissions # Called to set permissions of files/dirs in a directory structure. # With no options sets DirTag and all files/dirs in it to perms # # Parameters: # DirTag: The directory tag to start setting permissions on # # Required Options: # One or both of # --FilePerms= Sets the permissions of files to this permission. # If not supplied then no files have their permissions changed # --DirPerms= Sets the permissions of directories to this permission # If not supplied then no directories have their permissions changed # OR # --Perms= Sets the permissions of both files and directories to this permissions # Equivalent to supplying both --FilePerms=X && --DirPerms=X # # Options: # --Recurse Recurse the directory tree. Does a deptth first recurse so that all # dir entries are processed before the dir itself # --NoRecurse Dont recurse, default # --DirTagOnly Only sets the permissions on the DirTag directory, # all other options ignored # --SkipDirTag Does not set permissions on the DirTag Directory, # obviously mutually exlusive with --DirTagOnly # --FilterIn= Apply permissions to files/directories that matches this value. # --FilterInRE= Perl RE's can be used (Not Shell wildcards) and this option # can be supplied mulitple times # --FilterOut= Dont apply permissions to any files/directories matching this value # --FilterOutRE= Perl RE's can be used (Not Shell wildcards) and this option # can be supplied mulitple times # # FilterIn is applied before FilterOut. If Recurse is specified # the directory will be recursed regardless of these filters, however # the filter will be applied when it comes time to chmod the dir # #------------------------------------------------------------------------------ { my ( $dirTag, $filePerms, $dirPerms ); my ( $dirTagOnly, $skipDirTag ) = ( 0, 0 ); my $search = LocateFiles->new( recurse => 0, dirs_too =>1 ); foreach ( @_ ) { if ( m/^--Perms=(.*)/ ) { $filePerms = $1; $dirPerms = $1; } elsif ( m/^--FilePerms=(.*)/ ) { $filePerms = $1; } elsif ( m/^--DirPerms=(.*)/ ) { $dirPerms = $1; } elsif ( m/^--Recurse/ ) { $search->recurse(1); } elsif ( m/^--NoRecurse/ ) { $search->recurse(0); } elsif ( m/^--DirTagOnly/ ) { $dirTagOnly = 1; } elsif ( m/^--SkipDirTag/ ) { $skipDirTag = 1; } elsif ( m/^--FilterInRE=(.*)/ ) { $search->filter_in_re($1); } elsif ( m/^--FilterIn=(.*)/ ) { $search->filter_in($1); } elsif ( m/^--FilterOutRE=(.*)/ ) { $search->filter_out_re($1); } elsif ( m/^--FilterOut=(.*)/ ) { $search->filter_out($1); } else { Error("SetPermissions DirTag already set") if ( $dirTag ); $dirTag = $_; } } Error("SetPermissions called with out DirTag parameter") if ( !defined($dirTag) ); Error("SetPermissions called with out any Permission options") if ( !defined($filePerms) && !defined($dirPerms) ); Error("SetPermissions: Options --DirTagOnly & --SkipDirTag are mutually exclusive" ) if ( $dirTagOnly && $skipDirTag ); # # lets just check to see if the perms are in correct format. # if ( (defined($filePerms) && $filePerms !~ m/^\d{4}$/) || (defined($dirPerms) && $dirPerms !~ m/^\d{4}$/) ) { Error("setPermissions called with invalid permissions format"); } # Convert the symbolic target directory name into a real path my ($topDir) = getTargetDstDirValue($dirTag, "A"); # # Only set perms on the root directory # This is a trivial operation # if ( $dirTagOnly ) { Error("SetPermissions: --DirPerms or --Perms not supplied for setting perms with --DirTagOnly") if ( ! defined($dirPerms) ); Information("SetPermissions: Setting permissions on top level dir only [$topDir] to " . $dirPerms); chmodFile($topDir, $dirPerms); return; } Information("SetPermissions: Called with options " . join(", ", @_)); # # Create a list of files/dirs to process # my @elements = $search->search( $topDir ); Warning ("setPermissions: No files located") unless ( @elements ); foreach my $dirEntry ( @elements ) { my $fullPath = "$topDir/$dirEntry"; # A dir and we dont have dirperms, so skip if ( -d $fullPath && !defined($dirPerms) ) { Debug2("SetPermissions: Skipping dir $fullPath as we have no dir permissions"); next; } # A file and we dont have fileperms, so skip if ( -f $fullPath && !defined($filePerms) ) { Debug2("SetPermissions: Skipping file $fullPath as we have no file permissions"); next; } # a file or a dir and have the right permissions and we are not recursing if ( -f $fullPath || -d $fullPath ) { chmodFile($fullPath, ( -f $fullPath ) ? $filePerms : $dirPerms); } else { Warning("SetPermissions: Skipping $fullPath as its not a file or directory"); } } # # Process the topDir # May not be modified if --SkipDirTag has been requested # if ( !$skipDirTag && defined($dirPerms) ) { chmodFile($topDir, $dirPerms); } } # setPermissions #------------------------------------------------------------------------------ sub chmod # # Description: # This sub-routine is used to change the ownership of a file or # directory structure. # #------------------------------------------------------------------------------ { # correct number of parameters? Error("Incorrect number of params passed to chmod() function. Check deploy config.") if ( ($#_+1) != 3 ); # lets setup the passed values. my ($m_sDirTag, $m_sfile, $m_ownPerms) = @_; Warning("chmod has been deprecated by and now calls setPermissions, see deploylib.pm"); # call setPermissions, if no File then do DirTagOnly, otherwise set FilterIn=File setPermissions($m_sDirTag, "--NoRecurse", ($m_sfile) ? "--FilePerms=$m_ownPerms" : "--DirPerms=$m_ownPerms", ($m_sfile) ? "--FilterIn=$m_sfile" : "--DirTagOnly" ); return 1; } #------------------------------------------------------------------------------ sub chmodRecursive # # Description: # This sub-routine is used to change the permissions recursively in # the target packgae. # #------------------------------------------------------------------------------ { # correct number of parameters? Error("Incorrect number of params passed to chmodRecursive() function. Check deploy config.") if ( ($#_+1) != 2 ); # lets setup the passed values. my ($m_sDirTag, $m_ownPerms) = @_; Warning("chmodRecursive has been deprecated by and now calls setPermissions, see deploylib.pm"); # call setPermissions, if no File then do DirTagOnly, otherwise set FilterIn=File setPermissions($m_sDirTag, "--Recurse", "--Perms=$m_ownPerms"); return 1; } #------------------------------------------------------------------------------ sub chmodDir # # Description: # This sub-routine is used to change the permissions an entire directory tree. # # It recurses from a starting point chmod'ing each item and if it # finds a dir it recurses into that dir chmod'ing it as well. # #------------------------------------------------------------------------------ { # correct number of parameters? Error("Incorrect number of params passed to chmodDir() function.") if ( ($#_+1) != 2 ); my ($startingPoint, $perms) = @_; Warning("chmodDir has been deprecated by setPermissions, see deploylib.pm"); Verbose("chmodDir: Recursively setting permsision of [$startingPoint] to [$perms]"); local *DIR; opendir(DIR, $startingPoint) or Error("can't opendir $startingPoint: $!"); my ($item); while (defined($item = readdir(DIR))) { if ( "$item" !~ /^\.$/ && "$item" !~ /^\.\.$/ ) { if ( -d "$startingPoint/$item" ) { chmodDir("$startingPoint/$item", $perms); } else { chmodFile("$startingPoint/$item", $perms); } } } closedir (DIR); # lets deal with starting dir # chmodFile("$startingPoint", $perms); return 1; } #------------------------------------------------------------------------------ sub chmodFile # # this function is used to chmod the perms of an item # it is passed the absolute path to the item and the associated # perms. # #------------------------------------------------------------------------------ { my ($item, $perms) = @_; my ($noItems) = CORE::chmod oct($perms), $item; if ( $noItems == 0 ) { Error("ERROR: Failed to chmod $item=$perms, retVal=[$noItems]"); } else { Debug("Successfully chmod $item=$perms"); } return 1; } #------------------------------------------------------------------------------ sub createSymbolicLink # # Description: # This sub-routine is used to copy a local deployment file into # the target destination dir. # # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 3 ) { Error("Incorrect number of params passed to " . "createSymbolicLink() function. Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createSymbolicLink() not supported on this machine type."); return 1; } # lets setup the passed values. my ($m_sDirTag, $m_srcStr, $m_linkStr) = @_; # lets get the absolute src dir value my ($m_sDirAbsoluteValue) = getTargetDstDirValue($m_sDirTag, "A"); # lets see if the source item exists # if ( ! -f "$m_sDirAbsoluteValue/$m_srcStr" ) { Error("Failed to locate item [$m_sDirAbsoluteValue/$m_srcStr], link not created."); } my ($cmd) = "cd $m_sDirAbsoluteValue; ln -s $m_srcStr $m_linkStr"; system("$cmd"); if ( $? != 0 ) { Error("Failed to complete command: [$cmd]"); } else { Verbose("Executed command: [$cmd]"); } return 1; } #------------------------------------------------------------------------------ sub createPrototypeFile2 # # Description: # This sub-routine is used to create the required package prototype file # fom a known directory struture using the a=b format. # #------------------------------------------------------------------------------ { my ($opt_keep_mask, $opt_keep_links, @args); # # Process the arguments and extract parameters and options # foreach ( @_ ) { if ( m/^--KeepMask/ ) { $opt_keep_mask = 1; } elsif ( m/^--KeepLinks/ ) { $opt_keep_links = 1; } elsif ( m/^--/ ) { Error("createPrototypeFile2: Unknown option: $_") } else { push @args, $_; } } # correct number of parameters? if ( ($#args + 1) != 3 ) { Error("Incorrect number of params passed to " . "createPrototypeFile2() function. Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("createPrototypeFile2() not supported on this machine type."); return 1; } # lets take the passed in args. my ($uid, $gid, $mask) = @args; # we need to locate the prototype file if ( -f "$ProtoTypeFile" ) { unlink("$ProtoTypeFile"); Verbose("Removing prototype file [$ProtoTypeFile]."); } # lets open the prototype file. # local *FILE; open ( FILE, "> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); # lets populate the prototype file. printf FILE ("!default $mask $uid $gid\n"); printf FILE ("i pkginfo\n"); close (FILE); # lets put the pre-deinfed generic entries into the # prototype file # if ( "x$PkgPatchNum" ne "x" ) { addPatchInfo2ProtoTypeFile(); } # lets set the associated uid, gid and mask # for the bits in the prototype file. # $m_UID = $uid; $m_GID = $gid; $m_MASK = $mask; $m_KEEP_MASK = $opt_keep_mask; $m_KEEP_LINKS = $opt_keep_links; # now we need to add entries for each directory we will # be installing File::Find::find( \&prototype2Find, ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir ); # lets populate the prototype file with a newline. open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); printf FILE ("\n"); close (FILE); Information("Created prototype file [$ProtoTypeFile]."); return 1; } #------------------------------------------------------------------------------ sub prototype2Find # # Description: # This subroutine is used to locate all associated package dirs. # It also adds an entry into the prototype file for each dir. # #------------------------------------------------------------------------------ { my $file = $File::Find::name; # Our topdir will either be $PkgBaseDir or $PkgBaseDir/$TargetBaseDir (if there is a TargetBaseDir). # if we have PkgBaseDir only we dont want to include this in the prototype file, # if TargetBaseDir is defined we include it in the prototype if ( $file ne $PkgBaseDir ) { my ($sfile) = $file; # we get the absolute path from the find, but we only require a relative path from the starting dir. # So remove PkgBaseDir from path and include all dirs below it including TargetBaseDir if there is one $file =~ s|$PkgBaseDir/*||; # if TargetBaseDir is "." then find will find the pkginfo & prototype files so we need to exclude them if ( $file ne $ProtoTypeFileName && $file ne $PkgInfoFileName ) { my $fmask = $m_MASK; if ( $m_KEEP_MASK ) { $fmask = sprintf "%lo", ( (stat($sfile))[2]) & 07777; } open ( FILE, ">> $ProtoTypeFile") or Error("Failed to open file [$ProtoTypeFile]."); if ( $m_KEEP_LINKS && -l "$sfile" ) { my $linkDest = readlink($sfile); Warning("Link $sfile has an absolute path, may not be a problem but make sure its what you want") if ( $linkDest =~ /^\// ); printf FILE ("s none $file=$linkDest\n"); } elsif ( -f $sfile ) { printf FILE ("f none $file=$file $fmask $m_UID $m_GID\n"); } elsif ( -d $sfile ) { printf FILE ("d none $file $fmask $m_UID $m_GID\n"); } close (FILE); } } } #------------------------------------------------------------------------------- # Function : createZip # # Description : Create a ZIp file of a given directory # # Inputs : --Recurse - Recurse subdirs # --NoRecurse - Done recurse subdirs # --Dirnames - Record Dir names # --NoDirnames - Don't record dirnames # --NoQuiet - Display the operatios # --Dir=xxxx - Symbolic Directory to zip # --ZipDir=ttt - Symbolic target directory # --ZipFile=yyyy - Zipfile to create # # Returns : Will not return on error # Requires 'zip' to be provided by a 'package' such as InfoZip # sub createZip { my $recurse = 1; my $dirnames = 0; my $quiet = 1; my $sdir; my $tdir; my $tfile; # # Only on Windows at the moment. # Perhaps Unix should create a .gz file # Warning ("createZip not supported on $MachType. Operation skipped") unless ( "$MachType" eq "win32" ); # # Process user arguments # foreach ( @_ ) { if ( m/^--Recurse/ ) { $recurse = 1; } elsif ( m/^--NoRecurse/) { $recurse = 0; } elsif ( m/^--Dirnames/ ) { $dirnames = 1; } elsif ( m/^--NoDirnames/ ) { $dirnames = 0; } elsif ( m/^--NoQuiets/ ) { $quiet = 0; } elsif ( m/^--Dir=(.*)/ ) { $sdir = $1; } elsif ( m/^--ZipDir=(.*)/ ) { $tdir = $1; } elsif ( m/^--ZipFile=(.*)/ ) { $tfile = $1; } else { Warning("createZip: Unknown argument ignored: $_"); } } # # Convert the source directory TAG into a real directory # Error ("createZip: Source directory not specified") unless ( $sdir ); my $sdir_a = getTargetDstDirValue($sdir, "A"); # # Convert the destination directory tag into a real directory # Error ("createZip: Target directory not specified") unless ( $tdir ); Error ("createZip: Target filename not specified") unless ( $tfile ); my $tdir_a = getTargetDstDirValue($tdir, "A"); # # Locate the 'zip' uitilty # my $prog = LocateProgInPath( 'zip' ); Error ("createZip: Cannot locate ZIP executable", "May need to use the 'infozip' package") unless ( $prog ); # # Generate command file # my $args = '-9'; $args .= 'q' unless ( (! $quiet) || IsVerbose(1)); $args .= 'r' if ( $recurse ); $args .= 'j' unless ( $dirnames ); # # Zip up the files # Information ("Create Zip File: [$tdir] $tfile"); chdir ( $sdir_a ) || Error ("Cannot cd to $sdir_a"); my $rv = System ($prog, $args, "$tdir_a/$tfile", "." ); chdir($CurrentDir) || Error ("Cannot cd to $CurrentDir"); Error ("createZip: Zip file not created") if ( $rv ); } #------------------------------------------------------------------------------- # Function : convertFile # # Description : This sub-routine is used to remove all carrage return\line # feeds from a line and replace them with the platform # specific equivalent chars. # # We let PERL determine what characters are written to the # file base on the platform you are running on. # # i.e. LF for unix # CR\LF for win32 # # Inputs : m_targetDirTag - Symbolic name of target directory # m_nfiles - List of files in that directory # or # SearchOptions - Search options to find files # --Recurse # --NoRecurse # --FilterIn=xxx # --FilterInRE=xxx # --FilterOut=xxx # --FilterOutRE=xxx # # # Returns : 1 # sub convertFile { my @uargs; my $search = LocateFiles->new( recurse => 0 ); # # Process user arguments extracting options # foreach ( @_ ) { if ( m~^--Recurse~ ) { $search->recurse(1); } elsif ( m~^--NoRecurse~) { $search->recurse(0); } elsif ( /^--FilterOut=(.*)/ ) { $search->filter_out($1); } elsif ( /^--FilterOutRE=(.*)/ ) { $search->filter_out_re($1); } elsif ( /^--FilterIn=(.*)/ ) { $search->filter_in($1); } elsif ( /^--FilterInRE=(.*)/ ) { $search->filter_in_re($1); } elsif ( m~^--~) { Error ("convertFile: Unknown option: $_"); } else { push @uargs, $_; } } # # Process non-option arguments # - Base dir # - List of files # my ($m_targetDirTag, @m_nfiles) = @uargs; Error ("convertFiles: Target Dir must be specified" ) unless ( $m_targetDirTag ); # # Convert symbolic dir tag to physical path # my ($m_targetDirValue) = getTargetDstDirValue($m_targetDirTag, "A"); # # Need to determine if we are searching or simply using a file list # There are two forms of the functions. If any of the search options have # been used then we assume that we are searchine # if ( $search->has_filter() ) { Error ("convertFiles: Cannot mix search options with named files") if ( @m_nfiles ); @m_nfiles = $search->search($m_targetDirValue); } Error ("convertFiles: No files specified") unless ( @m_nfiles ); # # Process all named files # foreach my $m_nfile ( @m_nfiles ) { # this is our file that we want to clean. my ($m_ifileLoc) = "$m_targetDirValue/$m_nfile"; my ($m_tfileLoc) = "$m_targetDirValue/$m_nfile\.tmp"; # we will check to see if the file exists. # local *IFILE; local *TFILE; if ( -f "$m_ifileLoc" ) { open (IFILE, "< $m_ifileLoc" ) or Error("Failed to open file [$m_ifileLoc] : $!"); open (TFILE, "> $m_tfileLoc" ) or Error("Failed to open file [$m_tfileLoc] : $!"); while ( ) { s~[\n\r]+$~~; # Chomp print TFILE "$_\n"; } } else { Error("Deploy file [$m_ifileLoc] does not exist."); } close IFILE; close TFILE; # lets replace our original file with the new one # if(File::Copy::move("$m_tfileLoc", "$m_ifileLoc")) { Information("Renamed [$m_tfileLoc] to [$m_ifileLoc] ..."); } else { Error("Failed to rename file [$m_tfileLoc] to [$m_ifileLoc]: $!"); } } return 1; } #------------------------------------------------------------------------------- # Function : installDeployFile # # Description : This sub-routine is used to copy a local deployment file into # the target destination dir. # # Inputs : m_srcDirTag - Tag for Source Dir name # Tag defined in %LocalSrcDirStructure # Or --Package=name,subdir # Or --Interface=subdir # # m_sfile - Name of the source file # m_targetDirTag - Tag for the target directory # Tag defined in %TargetDstDirStructure # m_nfile - Target filename # Must be specified. If set to "", then # the source filename will be used. # # Returns : True # #------------------------------------------------------------------------------ sub installDeployFile { # correct number of parameters? if ( ($#_+1) != 4 ) { Error("Incorrect number of params passed to " . "installDeployFile() function. Check deploy config."); } my ($m_srcDirTag, $m_sfile, $m_targetDirTag, $m_nfile) = @_; # lets get the src dir value my ($m_targetDirValue) = getTargetDstDirValue($m_targetDirTag, "A"); # lets get the target dir value my ($m_srcDirValue) = getLocalDirValue($m_srcDirTag, "A"); # we know where we are getting this from and where we # going to put them. my ($m_sfileLoc) = "$m_srcDirValue/$m_sfile"; my ($m_nfileLoc) = ""; # lets determine what we are going to call the new file. # if ( "x$m_nfile" eq "x" ) { $m_nfileLoc = "$m_targetDirValue/$m_sfile"; } else { $m_nfileLoc = "$m_targetDirValue/$m_nfile"; } # we will check to see if the file exists. # if ( -f "$m_sfileLoc" ) { # now we need to copy the file. if(File::Copy::copy("$m_sfileLoc", "$m_nfileLoc")) { Verbose("Copied [$m_sfile] to [$m_nfileLoc] ..."); # now we need to ensure the item is writable as it # has come from our VOB that is by definition read-only # CORE::chmod oct("0755"), $m_nfileLoc; } else { Error("Failed to copy lib [$m_sfileLoc]: $!"); } } else { Error("Deploy file [$m_sfileLoc] does not exist."); } return 1; } #------------------------------------------------------------------------------ sub getGenericNameForLib # # Description: # This sub-routine is used to determine the generic name for # a library. I.E remove the buildtype and version number. # # It also checks if the name provided should be excluded from # the build. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "getGenericNameForLib() function. Check deploy config."); } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("getGenericNameForLib() not supported on this machine type."); return ""; } my($itemName) = @_; # first we need to check to see if it belongs in this build # my ($gName) = ""; if(excludeItemFromBuild($itemName)) { Verbose("Excluding item [$itemName] from build as not compatible with build type " . "[$BuildType]."); return ""; # file should be excluded. } else { $gName = removeBuildTypeFromItemName($itemName); $gName = removeVersionNumberFromItemName($gName); return "$gName"; } return 1; } #------------------------------------------------------------------------------ sub getGenericNameNoVersionForLib # # Description: # This sub-routine is used to determine the generic name for # a library. I.E removes the version number. # # It also checks if the name provided should be excluded from # the build. # #------------------------------------------------------------------------------ { my $installProdAndDebug; my $itemName = ""; # correct number of parameters? if ( (($#_+1) < 1) || (($#_+1) > 2)) { Error("Incorrect number of params passed to " . "getGenericNameNoVersionForLib() function. Check deploy config."); } # # Process parameters and extract options # foreach ( @_ ) { if ( m/^--InstallProdAndDebug/ ) { # not sure if the filename conventions allow the installation # of both prod/debug files on windows, so limit this to sparc/unix. if ( "$MachType" ne "sparc" ){ Error("Can only use the InstallProdAndDebug option for sparc."); } $installProdAndDebug = 1; } else { $itemName = $_; } } # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "sparc" ) { Verbose("getGenericNameNoVersionForLib() not supported on this machine type."); return ""; } # first we need to check to see if it belongs in this build. # if we've been told that both P & D are allowed, skip this check. my ($gName) = ""; if( !$installProdAndDebug && excludeItemFromBuild($itemName)) { Verbose("Excluding item [$itemName] from build as not compatible with build type " . "[$BuildType]."); return ""; # file should be excluded. } else { $gName = removeVersionNumberFromItemName($itemName); return "$gName"; } return 1; } #------------------------------------------------------------------------------ sub getGenericNameNoVersionForXML # # Description: # This sub-routine is used to determine the generic name for # an XML file. I.E removes the version number. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "getGenericNameNoVersionForXML() function. Check deploy config."); } my($itemName) = @_; my ($gName) = ""; $gName = removeVersionNumberFromXMLItemName($itemName); return "$gName"; return 1; } #------------------------------------------------------------------------------ sub removeVersionNumberFromXMLItemName # # Description: # This sub-routine is used to remove the version number from the item name. # i.e. myFile_1_2_3.xml ==> myFile.xml # # INPUT: # item name # # RETURN: # new item name. # #------------------------------------------------------------------------------ { my ($file) = @_; my ($nfile) = $file; if ( $nfile =~ m/_[0-9]+_[0-9]+_[0-9]+\.xml$/ ) { # if we match lets deal with it. $nfile =~ s/_[0-9]+_[0-9]+_[0-9]+\.xml$/\.xml/; } else { Warning("Filename [$nfile] does not contain required format [myfile_N_N_N.xml]."); } return "$nfile"; } #------------------------------------------------------------------------------ sub createDpkgArchive # # Description: # This sub-routine is used to create a dpkg_archive directory # structure. # #------------------------------------------------------------------------------ { # correct number of parameters? if ( ($#_+1) != 1 ) { Error("Incorrect number of params passed to " . "createDpkgArchive() function. Check deploy config."); } my ($desc) = @_; # lets just check to see if we can execute this function on # for this build. # if ( "x$PkgPatchNum" ne "x" ) { Verbose("createDpkgArchive() can only be called during a RELEASE build."); return 1; } # 1. we create a dpkg_archive top level dir within the output directory # my ($m_tmpDir) = "$PkgBaseDir/dpkg_archive"; make_directory( $m_tmpDir, 0777 ); # 2. we create a sub-directory with the package name # $m_tmpDir = ($TargetBaseDir ne ".") ? "$PkgBaseDir/dpkg_archive/$TargetBaseDir" : "$PkgBaseDir/dpkg_archive"; make_directory( $m_tmpDir, 0777 ); # 3. we create a sub-directory with the package version number # my ($m_tmpDir2) = "$m_tmpDir/${PkgVersion}.${ProjectAcronym}"; make_directory( $m_tmpDir2, 0777 ); # 4. we replacate the contents of the original outputdir/package name # to do this we shall execute a find starting within the original package target dir # any copy all items we find to the new location under the dpkg_archive/package/version dir. # File::Find::find( \&DpkgFind, ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir ); # 5. we create a descpkg file, with the Package Name, Version and Desc # my ($m_DescPkgFile) = "$m_tmpDir2/descpkg"; # now we need to update the prototype file # local *FILE; open ( FILE, ">> $m_DescPkgFile") or Error("Failed to open file [$m_DescPkgFile]."); printf FILE ("$PkgName, $PkgVersion.$ProjectAcronym - $desc\n"); close (FILE); # done. Information("createDpkgArchive() completed."); return 1; } #------------------------------------------------------------------------------ sub DpkgFind # # Description: # This subroutine is used to locate all associated items to # create a new dpkg_archive directory structure. # #------------------------------------------------------------------------------ { my($item)= "$File::Find::name"; my($base)= File::Basename::basename($item); # we get the absolute path from the find, but we only require # a relative path from the starting dir. my $srcdir = ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir; my $dstdir = ($TargetBaseDir ne ".") ? "$PkgBaseDir/dpkg_archive/$TargetBaseDir" : "$PkgBaseDir/dpkg_archive"; # we need to determine which file we are dealing with if ( ! -d "$item") { my ($m_sfile) = $item; $item =~ s|$srcdir|$dstdir/$PkgVersion\.$ProjectAcronym|; if(File::Copy::copy("$m_sfile", "$item")) { Verbose("Copied [$base] to [$item] ..."); } else { Error("Failed to copy pkg file [$m_sfile] to [$item]: $!"); } } else { # if no TargetBaseDir then we will pick up dpkg_archive dir so lets prune it if ( $_ eq "dpkg_archive" ) { $File::Find::prune = 1; } else { # we have found a dir my ($m_sDir) = $item; $item =~ s|$srcdir|$dstdir/$PkgVersion\.$ProjectAcronym|; make_directory( $item, 0777 ); } } } # This is now depricated sub generateReleaseNote { Error("generateReleaseNote is depricated please use generateHtmlReleaseNote"); return 1; } #------------------------------------------------------------------------------ sub generateHtmlReleaseNote # # Description: # #------------------------------------------------------------------------------ { Warning('Deprecated Function: generateHtmlReleaseNote'); } #------------------------------------------------------------------------------- # Function : generateXmlDependancy # # Description : Generate an XML file that describes the despendencies of the # released package. # # The generated file needs to be packaged for deployment. This # function will only create the file. It needs to be added to the # files that are deployed into the field. The file is primarily # to be used by Windows based applications, but its use may be # extended to other platforms. # # The file 'should' be deployed in the same directory as the main # application executable, so that the executable may locate it. # # The XML file is named after the package. It is prefixed with # the string "PkgInfo_". # # By default file will be placed in the 'TargetBaseDir'. # This behaviour may be modified by the user. # # Refer to package_info.xsd for details on the structure of the # generated XML file. Do not randomly chnage the structure. # It is being used. # # This function requires access to Release Manager in order # to locate the package description and build-time information # # The function will use the current/last version of the package # in an attempt to locate package information. # # # Inputs : platform - Platforms for which the file will be created # '*' indicate ALL platforms. # options - Options to control the detail of the generated file # # Valid options # --TargetDir - Symbolic target directory # Default: TargetBaseDir # # --Depth=nn - Depth to traverse the dependancy tree # All packages below this depth will be ignored # Default: 0. All packages will be included # --VisibleDepth=nn - Package beyond this depth will be marked as invisible # Default: 1. Only top level packages will be marked # as visible. # --Ignore=name - Ignore this package # It will not be included in the dependancy list # Default: None # --IgnoreChildren=name - Do not include children of this package\ # Default: None # --Invisible=name - Mark this package and its dependents as invisible # Default: None # --InvisibleChildren=name # - Mark this package as visible, but its dependents as invisible # Default: None # # Example: # generateXmlDependancy('*', '--TargetDir=OcpDir' ); # # # Returns : Nothing # sub generateXmlDependancy { my ($platforms, @opts) = @_; my %data; my $filename = "PkgInfo_$PkgName" . '.xml'; my $targetTag; return if ( ! ActivePlatform($platforms) ); Information("Generating XML dependancy information from RM data: $filename"); Warning ("This function is not compatible with Escrow builds"); # # Insert defaults # $data{default_visible} = 1; # # Parse the user options # foreach ( @opts ) { if ( m/^--Depth=(\d+)/ ) { $data{default_depth} = $1; } elsif ( m/^--VisibleDepth=(\d+)/ ) { $data{default_visible} = $1; } elsif ( m/^--Ignore=(.*)/ ) { $data{ignore}{$1} = 1; } elsif ( m/^--IgnoreChildren=(.*)/ ) { $data{ignore_child}{$1} = 1; } elsif ( m/^--Invisible=(.*)/ ) { $data{invisible}{$1} = 1; } elsif ( m/^--InvisibleChildren=(.*)/ ) { $data{invisible_child}{$1} = 1; } elsif ( m/^--TargetDir=(.*)/ ) { $targetTag = $1; } else { Error ("generateXmlDependancy: Unknown option: $_"); } } # # Sanity Tests # if ( $data{default_visible} && $data{default_depth} ) { Error ("generateXmlDependancy:Visible depth must be less than total depth") if ( $data{default_visible} > $data{default_depth} ); } # lets check to see if the target tag exists # if does not the process with log an error. # my $targetValue; if ( $targetTag ) { $targetValue = getTargetDstDirValue($targetTag, "A"); } else { $targetValue = ($TargetBaseDir ne ".") ? "$PkgBaseDir/$TargetBaseDir" : $PkgBaseDir; } $filename = $targetValue . '/' . $filename; # # Determine package information. # Must cater for a number of situations # 1) Package rebuild # 2) Package ripple # 3) New package # # Set defaults for elements in RM if not found DeployUtils::RmPkgInfo->DefaultDescription($PkgDesc); DeployUtils::RmPkgInfo->DefaultLabel($PkgLabel); # # Try with the current package version. It may be in RM # $RmPkgDetails = DeployUtils::RmPkgInfo->new( { PKG_NAME => $PkgName, PKG_VERSION => $PkgVersionUser, NO_WARN => 1 } ); unless ( $RmPkgDetails->foundDetails() && $PkgPreviousVersionStr ) { # # Try with the 'Previous' package # my $RmPkgDetailsPrev = DeployUtils::RmPkgInfo->new( { PKG_NAME => $PkgName, PKG_VERSION => $PkgPreviousVersionStr, NO_WARN => 1 } ); if ( $RmPkgDetailsPrev->foundDetails() ) { Information ("generateXmlDependancy. Using previous version ($PkgPreviousVersionStr)"); $RmPkgDetails = $RmPkgDetailsPrev; } } unless ( $RmPkgDetails->foundDetails() ) { Warning ("generateXmlDependancy. Package Information not in RM. Using defaults"); } # # %packages - information on packages that we have discovered # @to_process - An array of packages discovered, but not yet processed # my @to_process; # # Create the initial entry in the packages array # my @deps; foreach my $i ( $BuildFileInfo->getDpkgArchiveList() ) { my $moduleInfo = $BuildFileInfo->getDpkgArchiveInfo($i); my $tag = join ($;, $i, $moduleInfo->{versionFull} ); push @deps, $tag; } $data{packages}{$PkgName}{$PkgVersionUser}{date} = $RmPkgDetails->pv_modified_time() || localtime() ; $data{packages}{$PkgName}{$PkgVersionUser}{overview} = $RmPkgDetails->pv_description(); $data{packages}{$PkgName}{$PkgVersionUser}{deps} = [ @deps ] ; push @to_process, @deps; while ( my $entry = pop @to_process ) { my ($package, $version) = split ( $;, $entry ); # # Extract and save information for this package # next if ( exists $data{packages}{$package}{$version} ); # # Some packages need to be totally ignored # next if ( exists $data{ignore}{$package} ); my $RmPkgDetails = DeployUtils::RmPkgInfo->new( { PKG_NAME => $package, PKG_VERSION => $version, } ); Error ("generateXmlDependancy: Cannot locate base package: $package, $version") unless ( $RmPkgDetails->foundPkg() ); # # Determine the dependancies, unless we are ignoring the children too # Do not use the RmPkgInfo class method getDependencyNames to fetch the # dependancy information as this: # 1) gets it wrong # 2) Extracts a lot of data that we dont want. # my @deps; unless ( exists $data{ignore_child}{$package} ) { my $deps = $RmPkgDetails->getDependenciesHash(); foreach my $pkg ( keys %{$deps} ) { foreach my $ver ( keys %{$deps->{$pkg}} ) { my $tag = join ($;, $pkg, $ver ); push @deps, $tag; } } } $data{packages}{$package}{$version}{date} = $RmPkgDetails->pv_modified_time(); $data{packages}{$package}{$version}{overview} = $RmPkgDetails->pv_description(); $data{packages}{$package}{$version}{deps} = [ @deps ] ; push @to_process, @deps; } #DebugDumpData ("Packages", \%packages); # # Now walk the tree and generate XML # sub output_entry { my ($datap, $depth, $package, $version, $vis ) = @_; my $fh = $datap->{fh}; $depth++; # # Skip if too deep or an ignored package # return if ( $datap->{ignore}{$package} ); return if ( $datap->{default_depth} && $depth > $datap->{default_depth} ); # # Check for invisible packages # $vis = 0 if ( $datap->{invisible}{$package} ); my $indent = " " x ($depth - 1); my $date = $datap->{packages}{$package}{$version}{date}; my $overview = $datap->{packages}{$package}{$version}{overview}; # # Clean up the overview # $overview =~ s~\s+$~~; $overview =~ s~\r\n~\n~g; $overview =~ s~\n\r~\n~g; # # Determine visibility # $vis = 0 if ( $datap->{default_visible} && $depth > $datap->{default_visible} ); my $visible = ( $vis > 0 ) ? 'true' : 'false'; $vis = 0 if ( $datap->{invisible_child}{$package} ); # # The top level entry is different # if ( $depth == 0 ) { $indent = " " ; print $fh "\n"; print $fh "\n"; print $fh "$indent$package\n"; print $fh "$indent$version\n"; print $fh "$indent$overview\n"; print $fh "$indent$date\n"; } else { print $fh "${indent}\n"; print $fh "${indent} "; print $fh "${overview}" if ($overview); print $fh "\n"; } # # Process dependancies # unless ( $datap->{ignore_child}{$package} ) { foreach my $entry ( @{ $datap->{packages}{$package}{$version}{deps} } ) { my ($package, $version) = split ( $;, $entry ); output_entry ( $datap, $depth, $package, $version, $vis ); } } if ( $depth == 0 ) { print $fh "\n"; } else { print $fh "${indent}\n"; } } # # Output the XML header and information about the first package # Information ( "Creating file $filename" ); open ( $data{fh}, ">", $filename ) || Error( "Cannot create $filename"); output_entry ( \%data, -1, $PkgName, $PkgVersionUser, 1 ); close $data{fh}; # DebugDumpData( "DATA", \%data ); } #------------------------------------------------------------------------------ sub createPerlSvcWin32 # # Description: # This sub-routine is used to create a Win32 service # using a PERL script as the input. # # note we assume here that you have installed ther ActiveState PERL # developement KIT and have also installed a valid license key. # #------------------------------------------------------------------------------ { # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "win32" ) { Information("createPerlSvcWin32() not supported on this machine type."); return 1; } my ($m_srcDirTag, $m_sfile, $m_targetDirTag, $m_ofile, @m_libDirTags) = @_; # lets get the src dir value my ($m_targetDirValue) = getTargetDstDirValue($m_targetDirTag, "A"); # lets get the lib src dir value my (@m_libDirValue) = (); my $i; my ($_libStr) = ""; foreach $i ( 0 .. $#m_libDirTags ) { $m_libDirValue[$i] = getLocalDirValue($m_libDirTags[$i], "A"); $_libStr = $_libStr . "$m_libDirValue[$i];" } if ( -d $DpkgScriptsDir ) { $_libStr = $_libStr . "$DpkgScriptsDir"; } Verbose("additional places to look for perl modules, [$_libStr]"); # lets get the target dir value my ($m_srcDirValue) = getLocalDirValue($m_srcDirTag, "A"); # we know where we are getting this from and where we # going to put them. my ($m_sfileLoc) = "$m_srcDirValue/$m_sfile"; my ($_cmdStr) = "perlsvc --verbose --lib $_libStr --exe $m_targetDirValue/$m_ofile $m_sfileLoc"; # lets execute the package commands. my ($retVal); $retVal = system("$_cmdStr"); if ( $retVal != 0 ) { Error("Failed to complete command [$_cmdStr]."); } # done. return 1; } #------------------------------------------------------------------------------ sub createPerlAppWin32 # # Description: # This sub-routine is used to create a Win32 free-standing application # using a PERL script as the input. # # note we assume here that you have installed ther ActiveState PERL # developement KIT and have also installed a valid license key. # #------------------------------------------------------------------------------ { # lets just check to see if we can execute this function on # this machine. # if ( "$MachType" ne "win32" ) { Information("createPerlAppWin32() not supported on this machine type."); return 1; } my ($m_srcDirTag, $m_sfile, $m_targetDirTag, $m_ofile, @m_libDirTags) = @_; # lets get the src dir value my ($m_targetDirValue) = getTargetDstDirValue($m_targetDirTag, "A"); # lets get the lib src dir value my (@m_libDirValue) = (); my $i; my ($_libStr) = ""; foreach $i ( 0 .. $#m_libDirTags ) { $m_libDirValue[$i] = getLocalDirValue($m_libDirTags[$i], "A"); $_libStr = $_libStr . "$m_libDirValue[$i];" } if ( -d $DpkgScriptsDir ) { $_libStr = $_libStr . "$DpkgScriptsDir"; } Verbose("additional places to look for perl modules, [$_libStr]"); # lets get the target dir value my ($m_srcDirValue) = getLocalDirValue($m_srcDirTag, "A"); # we know where we are getting this from and where we # going to put them. my ($m_sfileLoc) = "$m_srcDirValue/$m_sfile"; my ($_cmdStr) = "perlapp --verbose --clean --force --lib $_libStr --exe $m_targetDirValue/$m_ofile --script $m_sfileLoc"; # lets execute the package commands. my ($retVal); $retVal = system("$_cmdStr"); if ( $retVal != 0 ) { Error("Failed to complete command [$_cmdStr]."); } # done. return 1; } #------------------------------------------------------------------------------- # Function : make_directory # # Description : Create a directory if it does not already exist # Simple function to provide user messages on the way # Will create a complete path. There is no need to # break it into bits. # # Inputs : name - path to the directory # umask - umask # text - User text (optional) # # Returns : # sub make_directory { my ($name, $umask, $text ) = @_; Error ("make_directory needs a umask") unless ( $umask ); Error ("make_directory needs a path") unless ( $name ); $text = "Create directory" unless ( $text ); my $umask_text = sprintf( "0%o", $umask ); unless ( -d $name ) { Verbose ( "$text: $name [$umask_text]"); mkpath ( $name, 0, $umask); } else { Verbose2 ( "$text: $name [$umask_text] - already exists"); } # # Ensure that the target directory is not setgid # as this will mess up the Solaris packaging process. The setgid on the # directories will be propergated into the final package. This is not good. # # If the user gets directories with SETGID, then they must be created # specifically after the directory has been created. # # Why is this a problem? Seen when a build user has directory setgid # for the purposes of making the directory accessible by many. # if ( -g $name ) { system ('chmod', 'g-s', $name ); Error ("Cannot remove setGID on directory.", "Dir: $name") if ( -g $name ); } } #------------------------------------------------------------------------------- # Function : ActivePlatform # # Description : Determine if the specified platform is currently 'active' # This is used by all user directives in order to determine # if the directive should be ignored for the current platform # # Inputs : $platform_spec - A (simple)platform specifier # # Returns : TRUE if the platform spec contains the current platform # sub ActivePlatform { my( $platform_spec ) = @_; Error ("No platform specified in some directive") unless ( $platform_spec ); # # Wild card # return 1 if ( $platform_spec eq '*' ); # # Simple test # foreach ( split (',', $platform_spec)) { return 1 if ( $_ eq $Platform ); } # # Not for me # return 0; } #------------------------------------------------------------------------------- # Function : LocatePackageBase # # Description : Locate a package and return the path to a directory within # the package # # Inputs : $ufn - User function. Error reporting # $PkgName - Name of the Package # $PkgSubDir - Subdir within the package # # # Returns : Absolute path to a directory within the package # my %LocatePackageBase_cache; sub LocatePackageBase { my ( $ufn, $PkgName, $PkgSubDir ) = @_; my $src_base_dir; if ( exists $LocatePackageBase_cache{$PkgName} ) { $src_base_dir = $LocatePackageBase_cache{$PkgName}; } else { # # Convert the package name into a real path name to the package as # held in dpkg_archive. Do not use the copy in the 'interface' directory # for my $entry ( $BuildFileInfo->getBuildPkgRules() ) { next unless ( $entry->{'DNAME'} eq $PkgName ); $src_base_dir = $entry->{'ROOT'}; Verbose ("Discovered package in: $src_base_dir"); } Error ("$ufn: Package not located: $PkgName") unless ( $src_base_dir ); Error ("$ufn: Package directory not found: $src_base_dir") unless ( -d $src_base_dir ); # # Mainatin a cache of located packages # $LocatePackageBase_cache{$PkgName} = $src_base_dir; } if ( defined $PkgSubDir ) { $src_base_dir .= '/' . $PkgSubDir; Error ("$ufn: Package subdirectory not found: $PkgSubDir" ) unless ( -d $src_base_dir ); } return $src_base_dir; } #=============================================================================== # # Internal Package # An attempt to simplify the WildCarding interface by capturing the parameters # in a package. The idea is that storing the arguments can be easier # package LocateFiles; use JatsError; #------------------------------------------------------------------------------- # Function : new # # Description : Create a new instance of a searcher # # Inputs : # # Returns : # sub new { my $class = shift; my $self = {}; $self->{recurse} = 0; $self->{exclude} = []; $self->{include} = []; $self->{base_dir} = undef; $self->{results} = []; $self->{dirs_too} = 0; bless ($self, $class); # # Process user arguments # These are are a hash # my %href = @_; foreach my $entry ( keys %href ) { Error( "LocateFiles:new. Unknown initialiser: $entry") unless ( exists $self->{$entry} ); $self->{$entry} = $href{$entry}; } return $self; } #------------------------------------------------------------------------------- # Function : Class accessor fucntions # recurse - Recurse subdirs # filter_in - Filter in these files # filter_in_re - Filter in (Regular Expression) # filter_out - Filter out these files # filter_out_re - Filter out (RE) # base_dir - Base dir for search # results - Results of the last search # dirs_too - Include dirs in the search # has_filter - Has any filter been defined # search - Perform the search # # Description : Accessor functions # # Inputs : class # One argument (optional) # # Returns : Current value of the daat item # sub recurse { my $self = shift; if (@_) { $self->{recurse} = shift } return $self->{recurse}; } sub filter_in { my $self = shift; if (@_) { push @{$self->{include}}, glob2pat( shift ) } return $self->{include}; } sub filter_in_re { my $self = shift; if (@_) { push @{$self->{include}}, shift } return $self->{include}; } sub filter_out { my $self = shift; if (@_) { push @{$self->{exclude}}, glob2pat( shift ) } return $self->{exclude}; } sub filter_out_re { my $self = shift; if (@_) { push @{$self->{exclude}}, shift } return $self->{exclude}; } sub dirs_too { my $self = shift; if (@_) { $self->{dirs_too} = shift } return $self->{dirs_too}; } sub base_dir { my $self = shift; if (@_) { $self->{base_dir} = shift } return $self->{base_dir}; } sub has_filter { my $self = shift; return ( ( @{$self->{include}} || @{$self->{exclude}} ) ); } #------------------------------------------------------------------------------- # Function : search # # Description : This function performs the search for files as specified # by the arguments already provided # # Inputs : base_dir (Optional) # # Returns : List of files that match the search criteria # my @search_list; # Must be global to avoid closure problems my $search_len; my $search_base_dir; my $search_dirs_too; sub search { my $self = shift; $self->{base_dir} = $_[0] if (defined $_[0] ); $self->{results} = (); # # Ensure user has provided enough info # Error ("LocateFiles: No base directory provided") unless ( $self->{base_dir} ); # # Clean up the user dir. Remove any trailing / as we will be adding it back # $self->{base_dir} =~ s~/*$~~g; # # Init recursion information # Needed to avoid closure interactions # @search_list = (); $search_len = length( $self->{base_dir} ); # # Create a list of candidate files # If we are recursing the subtree, then this is a little harder # If we are not recursing then we can't simply glob the directory as # not all files are processed. # # Will end up with a list of files that # 1) Start with a '/' # 2) Are rooted as $dir, but don't include $dir # if ( $self->{recurse} ) { $search_dirs_too = $self->{dirs_too}; $search_base_dir = $self->{base_dir}; sub find_file_wanted { return if ( !$search_dirs_too && -d $_ ); # skip if current is dir and we are not including dirs return if ( $search_base_dir eq $File::Find::name ); # skip if current is base_dir as we dont include it my $file = $File::Find::name; push @search_list, substr($file, $search_len ); } # # Under Unix we need to follow symbolic links, but Perl's # Find:find does not work with -follow under windows if the source # path contains a drive letter. # # Solution. Only use follow under non-windows systems. # Works as Windows does not have symlinks (yet). # my $follow_opt = ! ( "$MachType" eq "win32" || "$MachType" eq "WinCE" ); File::Find::find( {wanted => \&find_file_wanted, follow_fast => $follow_opt }, $self->{base_dir} ); } else { local *DIR ; opendir DIR, $self->{base_dir} || die ("Cannot open $self->{base_dir}"); foreach ( readdir( DIR ) ) { next if /^\Q.\E$/; next if /^\Q..\E$/; next if ( !$self->{dirs_too} && -d "$self->{base_dir}/$_" ); push @search_list, '/' . $_; } closedir DIR; } # # If filtering is not present then return the entire file list # $self->{results} = \@search_list ; return @search_list unless ( @{$self->{include}} || @{$self->{exclude}} ); # # Filtering is present # Apply the filterin rules and then the filter out rules # If no filter-in rules, then assume that all files are allowed in and # simply apply the filter-out rules. # my @patsin = map { qr/$_/ } @{$self->{include}}; my @patsout = map { qr/$_/ } @{$self->{exclude}}; my @result; # map { print "Include:$_\n"; } @{$self->{include}}; # map { print "Exclude:$_\n"; } @{$self->{exclude}}; file: foreach my $file ( @search_list ) { if ( @{$self->{include}} ) { my $in = 0; for my $pat (@patsin) { if ( $file =~ /$pat/ ) { $in = 1; last; } } #print "------- Not included $file\n" unless $in; next unless ( $in ); } for my $pat (@patsout) { #print "------- REJECT $file :: $pat \n" if ( $file =~ /$pat/ ); next file if ( $file =~ /$pat/ ); } push @result, $file; } $self->{results} = \@result; #DebugDumpData ("Search", $self); return @result; } #------------------------------------------------------------------------------- # Function : glob2pat # # Description : Convert four shell wildcard characters into their equivalent # regular expression; all other characters are quoted to # render them literals. # # Inputs : Shell style wildcard pattern # # Returns : Perl RE # sub glob2pat { my $globstr = shift; $globstr =~ s~^/~~; my %patmap = ( '*' => '[^/]*', '?' => '[^/]', '[' => '[', ']' => ']', ); $globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge; return '/' . $globstr . '$'; } #------------------------------------------------------------------------------ 1;