Rev 7398 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.## Module name : DebianPackager.pl# Module type : Makefile system# Compiler(s) : Perl# Environment(s): jats## Description : This program is invoked by the MakeDebianPackage and MakeRpmPackage# directive that is a part of this package## The program will use a user-provided script in order# to create the output Package.## The user script may call a number of directives in order to# construct an image of the package being installed.## The script specifies Debian/RPM configuration scripts that# will be embedded in the package.## This program will:# Construct a filesystem image under control of the directives# within the user script## Debian:# Massage the Debian control file# Create a Debian Package# Transfer it to the users 'BIN' directory, where it is available to be packaged.## RedHat Package:# Generate rpmBuilder control files# Create the RPM image# Transfer it to the users 'BIN' directory, where it is available to be packaged.## TarFile:# Tar Gzip the image# Transfer it to the users 'BIN' directory, where it is available to be packaged.## Summary of directives available to the user-script:# Message - Display progress text# Verbose - Display progress text# AddInitScript - Add an init script# CatFile - Append to a file# ConvertFile - Convert file(s) to Unix or Dos Text# CopyDir - Copy directory tree# CopyFile - Copy a file# CopyBinFile - Copy an executable file# CopyLibFile - Copy a library file# CopyDebPackage - Copy a Debian Package# CreateDir - Create a directory# AllFiles - Specify control and script files# DebianFiles - Specify control and script files (Debian Only)# RpmFiles - Specify control and script files (RPM Only)# AllControlFile - Specify control and script files# DebianControlFile - Specify control and script files (Debian Only)# RpmControlFile - Specify control and script files (RPM Only)# AllDepends - Add Depends entry to control file# DebianDepends - Add Depends entry to control file (Debian Only)# RpmDepends - Add Depends entry to control file (RPM Only)# EchoFile - Place text into a file# MakeSymLink - Create a symbolic link# PackageDescription - Specify the package description# ReplaceTags - Replace Tags on target file# SetFilePerms - Set file permissions# SetVerbose - Control progress display# IsProduct - Flow control# IsPlatform - Flow control# IsTarget - Flow control# IsVariant - Flow control# IsAlias - Flow control# RpmSetDefAttr - Specify default file properties (RPM Only)# RpmSetAttr - Specify file properties (RPM Only)# SetBaseDir - Sets base for installed files (RPM Hint for directory ownership)# Section - Set current section# PackageVersion - Return the version of a named package# ExtractTar - Extract a tar file into the target## Thoughts for expansion:# SrcDir - Extend path for resolving local files## Less used:# ExpandLinkFiles - Expand .LINK files## Internal Use:# FindFiles - Find a file# ResolveFile - Resolve a 'local' source file# chmodItem - Set file or directory permissions##......................................................................#require 5.006_001;use strict;use warnings;use Getopt::Long;use File::Path;use File::Copy;use File::Find;use Archive::Zip qw( :ERROR_CODES :CONSTANTS );use JatsSystem;use FileUtils;use ArrayHashUtils;use JatsError;use JatsLocateFiles;use ReadBuildConfig;use JatsCopy (); # Don't import anythinguse PackagerUtils;## Command line options#my $opt_debug = $ENV{'GBE_DEBUG'}; # Allow global debugmy $opt_verbose = $ENV{'GBE_VERBOSE'}; # Allow global verbosemy $opt_vargs; # Verbose argmy $opt_help = 0;my $opt_manual = 0;my $opt_clean = 0;my $opt_interfacedir;my $opt_package_script;my $opt_interfaceincdir;my $opt_interfacelibdir;my $opt_interfacebindir;my $opt_libdir;my $opt_bindir;my $opt_localincdir;my $opt_locallibdir;my $opt_localbindir;my $opt_pkgdir;my $opt_pkglibdir;my $opt_pkgbindir;my $opt_pkgpkgdir;my $opt_noarch;my $opt_tarFile;my $opt_tarOnly;my $opt_zipFile;my $opt_zipOnly;my $opt_rpm = 0;my $opt_debian = 0;my $opt_output;my $opt_imageOnly;my $opt_directPkg;## Options marked as 'our' so that they are visible within the users script# Don't give the user too much#our $opt_platform;our $opt_type;our $opt_buildname;our $opt_buildversion;our $opt_target;our $opt_product;our $opt_name;our $opt_version;our $opt_variant;our $opt_versionprefix;our $opt_extdesc;our $opt_pkgarch;our $opt_rpmRelease = '';## Options derived from script directives#my $opt_description;my $opt_specFile;## Globals#my $WorkDirBase; # Workspacemy $WorkDirInit; # Initial Dir to create file system image withinmy $WorkDir; # Dir to create file system image withinmy $WorkSubDir = ''; # Diff between $WorkDirInit and $WorkDirmy @ResolveFileList; # Cached Package File Listmy @ResolveBinFileList; # Cached PackageBin File Listmy @ResolveDebFileList; # Cached PackageDeb File Listmy @ResolveLibFileList; # Cached PackageLib File Listmy %ControlFiles; # Control Filesmy %ControlFileNames; # Control Files by namemy @DependencyList; # Package Dependenciesmy @ConfigList; # Config Filesmy %opt_aliases; # Cached Alias Namesmy @RpmDefAttr = ('-','root','root','-'); # RPM: Default File Attributesmy @RpmAttrList; # RPM: File attributesmy %OwnedDirs; # RPM: Dirs marked as ownedmy $ActiveSection = 1; # Indicates if the section is active#-------------------------------------------------------------------------------# Function : Main Entry point## Description : This function will be called when the package is initialised# Extract arguments from the users environment## Done here to greatly simplify the user script# There should be no junk in the user script - keep it simple## Inputs :## Returns :#main();sub main{my $result = GetOptions ('verbose:s' => \$opt_vargs,'clean' => \$opt_clean,'Type=s' => \$opt_type,'BuildName=s' => \$opt_buildname, # Raw Jats Package Name (Do not use)'Name=s' => \$opt_name, # Massaged Debian Package Name'Version=s' => \$opt_version, # Massaged Debian Version'BuildVersion=s' => \$opt_buildversion,'Platform=s' => \$opt_platform,'Target=s' => \$opt_target,'Product=s' => \$opt_product,'InterfaceDir=s' => \$opt_interfacedir,'InterfaceIncDir=s' => \$opt_interfaceincdir,'InterfaceLibDir=s' => \$opt_interfacelibdir,'InterfaceBinDir=s' => \$opt_interfacebindir,'LibDir=s' => \$opt_libdir,'BinDir=s' => \$opt_bindir,'LocalIncDir=s' => \$opt_localincdir,'LocalLibDir=s' => \$opt_locallibdir,'LocalBinDir=s' => \$opt_localbindir,'PackageDir=s' => \$opt_pkgdir,'PackageLibDir=s' => \$opt_pkglibdir,'PackageBinDir=s' => \$opt_pkgbindir,'PackagePkgDir=s' => \$opt_pkgpkgdir,'VersionPrefix:s' => \$opt_versionprefix,'Variant:s' => \$opt_variant,'ExtDesc:s' => \$opt_extdesc,'PkgArch:s' => \$opt_pkgarch,'NoArch' => \$opt_noarch,'tarFile=s' => \$opt_tarFile,'tarOnly' => \$opt_tarOnly,'zipFile=s' => \$opt_zipFile,'zipOnly' => \$opt_zipOnly,'genRpm' => \$opt_rpm,'genDeb' => \$opt_debian,'output=s' => \$opt_output,'script=s' => \$opt_package_script,'rpmRelease=s' => \$opt_rpmRelease,'imageOnly' => \$opt_imageOnly,'directPkg' => \$opt_directPkg,);$opt_verbose++ unless ( $opt_vargs eq '@' );ErrorConfig( 'name' => 'PackagerUtils','verbose' => $opt_verbose,'debug' => $opt_debug );## Init the FileSystem Uiltity interface#InitFileUtils();## Ensure that we have all required options#Error ("Platform not set") unless ( $opt_platform );Error ("Type not set") unless ( $opt_type );Error ("BuildName not set") unless ( $opt_buildname );Error ("BuildVersion not set") unless ( $opt_buildversion );Error ("Package Name not set") unless ( $opt_name );Error ("Package Version not set") unless ( $opt_version );Error ("InterfaceDir not set") unless ( $opt_interfacedir );Error ("Target not set") unless ( $opt_target );Error ("Product not set") unless ( $opt_product );Error ("Packaging Script not set") unless ( $opt_package_script );## Read in relevent config information#ReadBuildConfig ($opt_interfacedir, $opt_platform, '--NoTest' );## Build the package image in a directory based on the target being created#$WorkDirBase = uc("$opt_platform$opt_type.image");$WorkDirInit = "$WorkDirBase/$opt_name";$WorkDir = $WorkDirInit;if ($opt_directPkg) {## Package directly into the package being generated# Place stuff into the 'pkg' subdirectory# Ignore the name of the package#$WorkDirBase = $opt_pkgdir;$WorkDirInit = "$WorkDirBase/pkg";$WorkDir = $WorkDirInit;}## Configure the System command to fail on any error#SystemConfig ( ExitOnError => 1 );## Defaults#$opt_pkgarch = $opt_platform unless ( $opt_pkgarch );## Determine build operations#my $genDebian = $opt_debian;my $genRpm = $opt_rpm;if ($opt_tarOnly || $opt_zipOnly || $opt_imageOnly || $opt_directPkg) {$genDebian = $genRpm = 0;}## Display variables used#Message ("= Building Installer ================================================");Message (" Format: Debian") if ($genDebian);Message (" Format: RPM") if ($genRpm);Message (" Format: TGZ") if ($opt_tarFile);Message (" Format: ZIP") if ($opt_zipFile);Message (" Format: Image") if ($opt_imageOnly);Message (" Format: Directly Packaged Image") if ($opt_directPkg);Message (" Name: $opt_name");Message (" Package: $opt_buildname");Message (" Variant: $opt_variant") if ($opt_variant);Message (" Version: $opt_version");Message (" Building for: $opt_platform");Message (" Target: $opt_target") if ( $opt_platform ne $opt_target);Message (" Product: $opt_product") if ($opt_product ne $opt_platform);Message (" Type: $opt_type");Message (" RPM Release: $opt_rpmRelease") if ($opt_rpmRelease);Message (" Pkg Arch: $opt_pkgarch") if ($opt_pkgarch);Verbose (" Verbose: $opt_verbose");Verbose (" InterfaceDir: $opt_interfacedir");Message (" Output: " . $WorkDirInit ) if ($opt_imageOnly);Message (" Output: DPKG/pkg" ) if ($opt_directPkg);Message (" Output: " . StripDir($opt_output)) if ($genDebian || $genRpm);Message (" Output: " . StripDir($opt_tarFile)) if $opt_tarFile;Message (" Output: " . StripDir($opt_zipFile)) if $opt_zipFile;Message ("======================================================================");## Perform Clean up# Invoked during "make clean" or "make clobber"#if ( $opt_clean ){Message ("Remove packaging directory: $WorkDirInit");## Remove the directory for this package# Remove the general work dir - if all packages have been cleaned#rmtree( $WorkDirBase );rmtree ($opt_tarFile) if ( defined($opt_tarFile) && -f $opt_tarFile );rmtree ($opt_zipFile) if ( defined($opt_zipFile) && -f $opt_zipFile );rmtree ($opt_output) if ( $opt_output && -f $opt_output );exit;}## NoArch sanity test# MUST only build no-arch for production# User MUST do this in the build.pl file#if ($opt_noarch && $opt_type ne 'P'){Error ("Installer Packages marked as NoArch (all) must be built ONLY for production","This must be configured in the build.pl" );}## Clean out the WORK directory# Always start with a clean slate## Ensure that the base of the directory tree does not have 'setgid'# This will upset the debian packager# This may be an artifact from the users directory and not expected#rmtree( $WorkDirInit );mkpath( $WorkDirInit );my $perm = (stat $WorkDirInit)[2] & 0777;chmod ( $perm & 0777, $WorkDirInit );## Invoke the user script to do the hard work# Use abs path to avoid issues:# * '.' not buing in search path# * Script name = DebianPackager.pl$opt_package_script = AbsPath($opt_package_script);unless (my $return = do $opt_package_script) {Error ("Couldn't parse $opt_package_script: $@") if $@;Error ("Couldn't do $opt_package_script: $!") unless defined $return;};# Restore defaults$ActiveSection = 1;$WorkDir = $WorkDirInit;$WorkSubDir = '';## Now have an image of the directory that we wish to package# Complete the building of the package#if ($opt_tarFile) {BuildTarFile();Message ("Created TGZ file");}if ($opt_zipFile) {BuildZipFile();Message ("Created ZIP file");}## Create an RPM#if ($genRpm) {BuildRPM ();Message ("Created RPM");}## Create a Debian Package#if ($genDebian) {BuildDebianPackage ();Message ("Created Debian Package");}}#-------------------------------------------------------------------------------# Function : BuildRPM## Description : This function will create the Debian Package# and transfer it to the target directory## Inputs : None## Returns : Nothing#sub BuildRPM{## Sanity Checks#Error ("BuildRPM: Release")unless ( $opt_rpmRelease );Error ("BuildRPM: No Control File or Package Description")unless ( exists($ControlFiles{'control'}) || $opt_description );## Massage the 'control' file# Generate or Massage#$opt_specFile = catfile($WorkDirBase, 'RPM.spec' );UpdateRedHatControlFile ($ControlFiles{'control'} );# Generate a dummy rc filemy $rcFile = catdir($WorkDirBase,'tmprc');TouchFile($rcFile);## Run the RPM builder# Expect it to be installed on the build machine#my $prog = LocateProgInPath( 'rpmbuild', '--All');Error ("RPM Packager: The rpmbuild utility is not installed") unless $prog;System ($prog, '-bb', $opt_specFile,'--buildroot', AbsPath($WorkDirInit) ,'--define', '_rpmdir ' . StripFileExt($opt_output),'--define', '_rpmfilename ' . StripDir($opt_output),'--define', '_topdir ' . catfile($WorkDirBase, 'RPMBUILD' ),'--noclean',$opt_verbose ? '-v' : '--quiet',#$opt_noarch ? '--target=noarch' : undef,'--rcfile', $rcFile ,);}#-------------------------------------------------------------------------------# Function : BuildDebianPackage## Description : This function will create the Debian Package# and transfer it to the target directory## Inputs : None## Returns : Nothing#sub BuildDebianPackage{Error ("BuildDebianPackage: No Control File or Package Description")unless ( exists($ControlFiles{'control'}) || $opt_description );## Convert the FileSystem Image into a Debian Package# Insert Debian control files#Verbose ("Copy in the Debian Control Files");mkdir ( "$WorkDirInit/DEBIAN" );## Copy in all the named Debian Control files# Ignore any control file. It will be done next#foreach my $key ( keys %ControlFiles ){next if ($key eq 'control');CopyFile ( $ControlFiles{$key}, '/DEBIAN', $key );}## Create 'conffiles'# Append to any user provided fileif ( @ConfigList ){my $conffiles = "$WorkDirInit/DEBIAN/conffiles";Warning("Appending user specified entries to conffiles") if ( -f $conffiles);FileAppend( $conffiles, @ConfigList );}## Massage the 'control' file#UpdateDebianControlFile ($ControlFiles{'control'} );## Mark all files in the debian folder as read-execute#System ( 'chmod', '-R', 'a+rx', "$WorkDirInit/DEBIAN" );System ( 'build_dpkg.sh', '-b', $WorkDirInit);System ( 'mv', '-f', "$WorkDirInit.deb", $opt_output );System ("build_dpkg.sh", '-I', $opt_output) if (IsVerbose(1));}#-------------------------------------------------------------------------------# Function : BuildTarFile## Description : This function will create a TGZ file of the constructed package# Not often used## Inputs : None## Returns : Nothing#sub BuildTarFile{Verbose ("Create TGZ file containing body of the package");System ('tar','--create','--auto-compress','--owner=0' ,'--group=0' ,'--one-file-system' ,'--exclude=./DEBIAN' ,'-C', $WorkDirInit,'--file', $opt_tarFile,'.');}#-------------------------------------------------------------------------------# Function : BuildZipFile## Description : This function will create a ZIP file of the constructed package# Not often used## Tricky bit is excluding the DEBIAN directory## Inputs : None## Returns : Nothing#sub BuildZipFile{Verbose ("Create ZIP file containing body of the package");my $zip = Archive::Zip->new();$zip->addTree( $WorkDirInit, '', sub { $_ !~ m~^DEBIAN$~ } );if ( $zip->writeToFileNamed($opt_zipFile) != AZ_OK ) {Error("Canot create ZIP file");}}#-------------------------------------------------------------------------------# Function : Section## Description : Allows the Package file to be split into section# This direcive is always active.## Inputs : Selector# ALL - Active# RPM - Active section when building an RPM# DEBIAN - Active section if build a Debian package# TAR - Active section if building a TAR# ZIP - Active section if building a ZIP## Returns : Nothing# Will fkag to indicate if directives are active.#sub Section{my $newActiveSection;my $flip = sub {my ($val, $mode) = @_;if ( defined $mode) {return $val ? 0 : 1;}return $val;};$newActiveSection = 1 unless (@_);foreach my $arg ( @_){if ($arg =~ m/^(!)*DEBIAN/i) {$newActiveSection = 1 if $flip->($opt_debian, $1);} elsif ($arg =~ m/^(!)*RPM/i) {$newActiveSection = 1 if $flip->($opt_rpm, $1);} elsif ($arg =~ m/^(!)*TAR/i) {$newActiveSection = 1 if $flip->($opt_tarFile, $1);} elsif ($arg =~ m/^(!)*ZIP/i) {$newActiveSection = 1 if $flip->($opt_zipFile, $1);} elsif (uc($arg) eq 'ALL') {$newActiveSection = 1;} elsif ( $arg eq 1 ) {$newActiveSection = 1;} elsif ( $arg eq 0 ) {} else {Warning ("Section: Unknown argument $arg");}}$ActiveSection = $newActiveSection ? 1: 0;Verbose ("Section State: $ActiveSection");}#-------------------------------------------------------------------------------# Function : UpdateDebianControlFile## Description : Update the Debian 'control' file to fix up various fields# within the file.## If the files has not been specified, then a basic control# file will be provided.## This routine knows where the control file will be placed# within the output work space.## Inputs : $src - Path to source file# Uses global variables## Returns : Nothing#sub UpdateDebianControlFile{my($src) = @_;return 1 unless ($ActiveSection);my $dst = "$WorkDirInit/DEBIAN/control";unless ( $src ){CreateDebianControlFile();return;}## User has provided a control file# Tweak the internals#Verbose ("UpdateDebianControlFile: $dst" );$src = ResolveFile( 0, $src );# Calc depends linemy $depData = join (', ', @DependencyList );open (SF, '<', $src) || Error ("UpdateDebianControlFile: Cannot open:$src, $!");open (DF, '>', $dst) || Error ("UpdateDebianControlFile: Cannot create:$dst, $!");while ( <SF> ){s~\s*$~~;if ( m~^Package:~ ) {$_ = "Package: $opt_name";} elsif ( m~^Version:~ ) {$_ = "Version: $opt_version";} elsif ( m~^Architecture:~ ) {$_ = "Architecture: $opt_pkgarch";} elsif ( $opt_description && m~^Description:~ ) {$_ = "Description: $opt_description";} elsif ( m~^Depends:~ ) {$_ = "Depends: $depData";$depData = '';}print DF $_ , "\n";}close (SF);close (DF);## Warn if Depends section is needed#Error ("No Depends section seen in user control file")if ($depData);}#-------------------------------------------------------------------------------# Function : CreateDebianControlFile## Description : Create a basic debian control file## Inputs : Uses global variables## Returns :#sub CreateDebianControlFile{return 1 unless ($ActiveSection);my $dst = "$WorkDirInit/DEBIAN/control";Verbose ("CreateDebianControlFile: $dst" );my $depData = join (', ', @DependencyList );open (DF, '>', $dst) || Error ("CreateDebianControlFile: Cannot create:$dst");print DF "Package: $opt_name\n";print DF "Version: $opt_version\n";print DF "Section: main\n";print DF "Priority: standard\n";print DF "Architecture: $opt_pkgarch\n";print DF "Essential: No\n";print DF "Maintainer: Vix Technology\n";print DF "Description: $opt_description\n";print DF "Depends: $depData\n" if ($depData);close (DF);}#-------------------------------------------------------------------------------# Function : UpdateRedHatControlFile## Description : Update the Redhat 'control' file to fix up various fields# within the file.## If the files has not been specified, then a basic control# (spec) file will be provided.# Various tags will be replaced# tag_name# tag_version# tag_buildarch# tag_release# tag_description# tag_requires# tag_filelist## Inputs : $src - Path to source file# Uses global variables## Returns : Nothing#sub UpdateRedHatControlFile{my($src) = @_;return 1 unless ($ActiveSection);my $dst = $opt_specFile;unless ( $src ){CreateRedHatControlFile();return;}## User has provided a control file# Tweak the internals#Verbose ("UpdateRedHatControlFile: $dst" );$src = ResolveFile( 0, $src );my @depList = @DependencyList;my $cleanSeen;open (my $sf, '<', $src) || Error ("UpdateRedHatControlFile: Cannot open:$src, $!");open (my $df, '>', $dst) || Error ("UpdateRedHatControlFile: Cannot create:$dst, $!");while ( <$sf> ){s~\s*$~~;if ( m~^tag_Name~i ) {$_ = "Name: $opt_name";} elsif ( m~^tag_Version~i ) {$_ = "Version: $opt_version";} elsif ( m~^tag_BuildArch~i ) {$_ = "BuildArch: $opt_pkgarch";} elsif ( m~^tag_Release~i ) {$_ = "Release: $opt_rpmRelease";} elsif ( $opt_description && m~^tag_Description~i ) {print $df "%description\n";print $df "$opt_description\n";$_ = undef;} elsif ( m~^tag_Requires~i ) {foreach my $item (@depList) {print $df "Requires: $item\n";}$_ = undef;@depList = ();} elsif ( m~^tag_filelist~i ) {GenerateRedHatFileList ($df);$_ = undef;} elsif ( m~^%clean~i ) {$cleanSeen = 1;}print $df ($_ , "\n") if defined ($_);}close ($sf);close ($df);## Warn if Depends section is needed#Error ("No %clean section seen in user control file") unless $cleanSeen;Error ("No Requires tag seen in user control file") if (@depList);}#-------------------------------------------------------------------------------# Function : CreateRedHatControlFile## Description : Create a binary RedHat spec file## Inputs : Uses global variables## Returns :#sub CreateRedHatControlFile{## Generate the RPM spec file#open (my $sf, '>', $opt_specFile) || Error ("RPM Spec File: Cannot create: $opt_specFile, $!");# Standard tagsprint $sf ("# Standard SPEC Tags\n");print $sf "Summary: Installer for the $opt_name Package\n";print $sf "Name: $opt_name\n";print $sf "Version: $opt_version\n";print $sf "Release: $opt_rpmRelease\n";print $sf "License: COPYRIGHT - VIX IP PTY LTD (\"VIX\"). ALL RIGHTS RESERVED.\n";print $sf "Source: None\n";print $sf "BuildArch: $opt_pkgarch\n";print $sf "Group: VIX/System\n";print $sf "Vendor: Vix Technology\n";print $sf "Autoreq: No\n";## Requires tags#print $sf "\n# Dependencies\n" if @DependencyList;foreach my $item (@DependencyList) {print $sf "Requires: $item\n";}print $sf "\n";print $sf "%description\n";print $sf "$opt_description\n";print $sf "\n";print $sf "%clean\n";## Insert various scripts#my $insertRpmControlFile = sub {my ($sname, $cname) = @_;if ( my $src = $ControlFiles{$cname} ) {print $sf "\n";print $sf '%' . $sname . "\n";open ( my $cf, '<', $src ) || Error ("BuildRPM: Cannot open:$src, $!");while ( <$cf> ) {$_ =~ s~\%~%%~g;print $sf $_;}close ($cf);print $sf "\n";}};# Run the PreInstall script as %pretrans# %pretrans is the only script that can terminate the RPM installation&$insertRpmControlFile ('pretrans', 'preinst');&$insertRpmControlFile ('post', 'postinst');&$insertRpmControlFile ('preun', 'prerm');&$insertRpmControlFile ('postun', 'postrm');## On many packages the RPM "Checking for unpackaged file(s)"# can take a long while (minutes). It can't be disabled# but it can be made faster by disabling compression of the RPM#print $sf "\n%define _unpackaged_files_terminate_build 0\n";print $sf "\n%define _source_payload w0.gzdio\n";print $sf "\n%define _binary_payload w0.gzdio\n";## Insert the list of files to be processed# Can't use /* as this will mess with permissions of the root directory.# Can list Top Level directories and then use *#print $sf "\n%files\n";print $sf "%defattr(",join (',', @RpmDefAttr),")\n";GenerateRedHatFileList ($sf);print $sf "\n";close ($sf);}#-------------------------------------------------------------------------------# Function : GenerateRedHatFileList## Description : Internal function# Generate a file list to be inserted into an RPM spec file## Inputs : $fd - File descriptor.# Function will write directly to the output## Returns : Nothing#sub GenerateRedHatFileList{my ($fd) = @_;## Sanity Test#Warning ("No directories has been marked as 'Owned'","Under RedHat a directory must be 'owned' by a package so that it can be removed.","This ownership may be in that package or a 'Required' package.","This ownership may be shared or exclusive.",) unless scalar keys %OwnedDirs;## Flag files and directories with attributes#my %Attrs;my %Dirs;foreach my $item ( @RpmAttrList ) {my $file = $item->[0];my $full_path = $WorkDirInit . $file;$Attrs{$file} = '%attr(' . join(',',@{$item}[1..3] ) . ')';$Dirs{$file} = '%dir' if (-d $full_path);}## Flag configuration files ( ConfFile )#my %Configs;foreach my $item (@ConfigList) {$Configs{$item} = '%config';}## Internal subroutine to pretty-print a file/dirname with attributes# $path - path element# $isDir - True if a directory#my $printer = sub {my ($path, $isDir) = @_;my $attrText = delete $Attrs{$path};my $confText = delete $Configs{$path};my $dirText = delete $Dirs{$path};$dirText = '%dir' if $isDir;my $txt;my $joiner = '';$path = '"' . $path . '"';foreach ($attrText,$dirText,$confText, $path) {next unless $_;$txt .= $joiner . $_;$joiner = ' ';}print $fd ("$txt\n");};## List all files in the tree# If we use wildcards we get interpackage dependency issues# Process files and directories#my $search = JatsLocateFiles->new( '--Recurse', '--NoFullPath', '--DirsToo' );my @flist = $search->search($WorkDirInit);foreach (@flist) {my $file = '/' . $_;my $full_path = $WorkDirInit . $file;my $isDir = (-d $full_path) || 0;## Determine if the element is within a known RootDir#my $inRoot = 0;my $isOwner = 0;foreach (keys %OwnedDirs) {if ($file =~ m~^$_~) {$inRoot = 1;$isOwner = $OwnedDirs {$_};last;}}## Ignore directories that are not within a RootDir#unless ($inRoot) {next if $isDir;}## Ignore directories that are not within an 'owned' directory#if ( !$isOwner && $isDir ) {next;}&$printer($file, $isDir);}## Sanity tests# We should have process all the Configs and Attributes#if ( (keys %Configs) || ( keys %Attrs)){Error ("Internal Error. Unprocessed Config or Attributes.",keys %Configs, keys %Attrs );}}#-------------------------------------------------------------------------------# Function : SetVerbose## Description : Set the level of verbosity# Display activity## Inputs : Verbosity level# 0 - Use makefile verbosity (Default)# 1..2## Returns :#sub SetVerbose{return 1 unless ($ActiveSection);my ($level) = @_;$level = $opt_verbose unless ( $level );$opt_verbose = $level;ErrorConfig( 'verbose' => $level);}#-------------------------------------------------------------------------------# Function : SetBaseDir## Description : Sets the root directory for all directories# Used to simplify scripts## Inputs : $path - Absolute path. Now within the RootDir# @options - As for CreateDir## Returns : Nothing# Sets $WorkDir#sub SetBaseDir{my ($path, @opts) = @_;return 1 unless ($ActiveSection);my $rootdir = $path || '/';$rootdir = '/' . $rootdir;$rootdir =~ s~/+~/~g;Verbose ("Setting RootDir: $rootdir");## Create the directory#$WorkDir = $WorkDirInit;CreateDir ($rootdir, @opts);$WorkSubDir = $rootdir;$WorkDir = $WorkDirInit . $rootdir;}#-------------------------------------------------------------------------------# Function : DebianFiles# RpmFiles# AllFiles## Description : Name Debian and RPM builder control files# May be called multiple times## Inputs : $fName - Name under which the function is being called# Options# --Control=file# --PreRm=file# --PostRm=file# --PreInst=file# --PostInst=file# --SimpleSharedLibs### Returns : Nothing#sub MULTI_Files{my $fName = shift;return 1 unless ($ActiveSection);Verbose ("Specify Installer Control Files and Scripts");foreach ( @_ ){if ( m/^--Control=(.+)/i ) {MULTI_ControlFile($fName, 'control',$1)} elsif ( m/^--PreRm=(.+)/i ) {MULTI_ControlFile($fName, 'prerm',$1)} elsif ( m/^--PostRm=(.+)/i ) {MULTI_ControlFile($fName, 'postrm',$1)} elsif ( m/^--PreInst=(.+)/i ) {MULTI_ControlFile($fName, 'preinst',$1)} elsif ( m/^--PostInst=(.+)/i ) {MULTI_ControlFile($fName, 'postinst',$1)} elsif ( m/^--SimpleSharedLibs/i ) {my $file = catfile($WorkDirBase, 'ldconfig.sh' );open (my $df, '>', $file) || Error ("$fName: Cannot create:$file");print $df "#!/bin/sh\n";print $df "/sbin/ldconfig\n";print $df "exit 0\n";close $df;MULTI_ControlFile($fName, 'postinst',$file);MULTI_ControlFile($fName, 'postrm',$file);} else {Error ("$fName: Unknown option: $_");}}}#-------------------------------------------------------------------------------# Function : DebianControlFile# RpmControlFile# AllControlFile## Description : Add special control files to the Debian/RedHat Installer# Not useful for embedded installers## More general than DebianFiles() or RpmFiles## Inputs : name - Target Name# If the name starts with 'package.' then it will be replaced# with the name of the current package# Ideally: prerm, postrm, preinst, postinst# file - Source File Name# options - Options include# --FromPackage## Returns :#sub MULTI_ControlFile{my ($fName, $name, $file, @options) = @_;return 1 unless ($ActiveSection);my $fromPackage = 0;## Process optionsforeach ( @options){if (m~^--FromPackage~) {$fromPackage = 1;}else {ReportError(("$fName: Unknown argument: $_"));}}ErrorDoExit();## Some control files need to have the package name prepended#$name =~ s~^package\.~$opt_name.~;## Only allow one file of each type# Try to protect the user by testing for names by lowercase#my $simpleName = lc($name);Error("$fName: Multiple definitions for '$name' not allowed")if (exists $ControlFileNames{$simpleName});my $filePath = ResolveFile($fromPackage, $file);## Add info to data structures#$ControlFiles{$name} = $filePath;$ControlFileNames{$simpleName} = $name;}#-------------------------------------------------------------------------------# Function : DebianDepends# RpmDepends# AllDepends## Description : This directive allows simple dependency information to be# inserted into the control file## Names will be massaged into conforming names.## Not useful in embedded system## Inputs : Entry - A dependency entry# ... - More entries# Options# --Raw - Prevent name modification# --NoRaw - Enable name modification### Returns : Nothing#sub MULTI_Depends{return 1 unless ($ActiveSection);shift;my $raw = 0;## Convert the provided name into a canonical name# Simplifies use when using both RPM and Debianforeach ( @_){if (m~^--(No)?Raw~i) {$raw = ! defined($1);next;}my $name = $_;$name = canonicalName($_, $opt_rpm ? 'RPM' : 'DEBIAN' , 1) unless $raw;push @DependencyList, $name;}}#-------------------------------------------------------------------------------# Function : PackageDescription## Description : Specify the Package Description# Keep it short## Inputs : $description## Returns :#sub PackageDescription{return 1 unless ($ActiveSection);($opt_description) = @_;}#-------------------------------------------------------------------------------# Function : MakeSymLink## Description : Create a symlink - with error detection## Inputs : old_file - Link Target# Path to the link target# If an ABS path is provided, the routine will# attempt to create a relative link.# new_file - Relative to the output work space# Path to where the 'link' file will be created# Options - Must be last# --NoClean - Don't play with links# --NoDotDot - Don't create symlinks with ..## Returns : Nothing#sub MakeSymLink{my $no_clean;my $no_dot;my @args;return 1 unless ($ActiveSection);## Extract options#foreach ( @_ ){if ( m/^--NoClean/i ) {$no_clean = 1;} elsif ( m/^--NoDotDot/i ) {$no_dot = 1;} elsif ( m/^--/ ) {Error ("MakeSymLink: Unknown option: $_");} else {push @args, $_;}}my ($old_file, $new_file) = @args;my $tfile = $WorkDir . '/' . $new_file;$tfile =~ s~//~/~;Verbose ("Symlink $old_file -> $new_file" );## Create the directory in which the link will be placed# Remove any existing file of the same name#my $dir = StripFileExt( $tfile );mkpath( $dir) unless -d $dir;unlink $tfile;## Determine a good name of the link# Convert to a relative link in an attempt to prune them#my $sfile = $old_file;unless ( $no_clean ){$sfile = CalcRelPath( StripFileExt( $new_file ), $old_file );$sfile = $old_file if ( $no_dot && $sfile =~ m~^../~ );}my $result = symlink $sfile, $tfile;Error ("Cannot create symlink. $old_file -> $new_file") unless ( $result );}#-------------------------------------------------------------------------------# Function : CopyFile## Description : Copy a file to a target dir# Used for text files, or files with fixed names## Inputs : $src# $dst_dir - Within the output workspace# $dst_name - Output Name [Optional]# Options - Common Copy Options## Returns : Full path to destination file#sub CopyFile{return 1 unless ($ActiveSection);CopyFileCommon( \&ResolveFile, @_ );}#-------------------------------------------------------------------------------# Function : CopyBinFile## Description : Copy a file to a target dir# Used for executable programs. Will look in places where# programs are stored.## Inputs : $src# $dst_dir - Within the output workspace# $dst_name - Output Name [Optional]## Options:# --FromPackage# --SoftLink=xxxx# --LinkFile=xxxx## Returns : Full path to destination file#sub CopyBinFile{return 1 unless ($ActiveSection);CopyFileCommon( \&ResolveBinFile, @_ );}#-------------------------------------------------------------------------------# Function : CopyLibFile## Description : Copy a file to a target dir# Used for shared programs. Will look in places where# shared libraries are stored.## Inputs : $src - Base for 'realname' (no lib, no extension)# $dst_dir - Within the output workspace# $dst_name - Output Name [Optional, but not suggested]## Returns : Full path to destination file## Notes : Copying 'lib' files# These are 'shared libaries. There is no provision for copying# static libraries.## The tool will attempt to copy a well-formed 'realname' library# The soname of the library should be constructed on the target# platform using ldconfig.# There is no provision to copy the 'linker' name## Given a request to copy a library called 'fred', then the# well formed 'realname' will be:# libfred[P|D|]].so.nnnnn# where:# nnnn is the library version# [P|D|] indicates Production, Debug or None## The 'soname' is held within the realname form of the library# and will be created by lsconfig.## The 'linkername' would be libfred[P|D|].so. This is only# needed when linking against the library.### The routine will also recognize Windows DLLs# These are of the form fred[P|D|].nnnnn.dll#sub CopyLibFile{return 1 unless ($ActiveSection);CopyFileCommon( \&ResolveLibFile, @_ );}#-------------------------------------------------------------------------------# Function : CopyDebianPackage## Description : Copy a Debian Package to a target dir# Will look in places where Debian Packages are stored.## Inputs : $src - BaseName for 'Debian Package' (no version, no extension)# $dst_dir - Within the output workspace# Optional arguments embedded into the BaseName# --Arch=XXXX - Architecture - if not current# --Product=XXXX - Product - if required# --Debug - If not the current type# --Prod - If not the current type## Returns : Full path to destination file## Notes : Copying Debian Packages from external packages## The tool will attempt to copy a well-formed debian packages# These are:## "BaseName_VersionString[_Product]_Arch${PkgType}.deb";## Where 'Product' is optional (and rare)# Where 'PkgType' is P or D or nothing# Where 'Arch' may be 'all'## The routine will locate Debian packages in# - The root of the package# - bin/TARGET[P|D/]# - bin/Arch[P|D]##sub CopyDebianPackage{return 1 unless ($ActiveSection);CopyFileCommon( \&ResolveDebPackage, '--FromPackage', @_ );}#-------------------------------------------------------------------------------# Function : CopyFileCommon## Description : Common ( internal File Copy )## Inputs : $resolver - Ref to function to resolve source file# $src - Source File Name# $dst_dir - Target Dir# $dst_name - Target Name (optional)# Options# Options:# --FromPackage# --FromBuild# --SoftLink=xxxx# --LinkFile=xxxx# --ConfFile# --Platform=xxxx[,yyyyy]## Returns :#sub CopyFileCommon{my $from_package = 0;my $isa_linkfile = 0;my $isa_configFile = 0;my @llist;my @args;my @platforms;## Parse options#foreach ( @_ ){if ( m/^--FromPackage/ ) {$from_package = 1;} elsif ( m/^--FromBuild/ ) {$from_package = 0;} elsif ( m/^--LinkFile/ ) {$isa_linkfile = 1;} elsif ( m/^--ConfFile/i ) {$isa_configFile = 1;} elsif ( m/^--SoftLink=(.+)/ ) {push @llist, $1;} elsif ( m/^--Platform=(.+)/ ) {push @platforms, split(',', $1 );} elsif ( m/^--/ ) {Error ("FileCopy: Unknown option: $_");} else {push @args, $_;}}## Extract non-options.# These are the bits that are left over#my ($resolver, $src, $dst_dir, $dst_name ) = @args;## Clean up dest_dir. Must start with a / and not end with one#$dst_dir = "/$dst_dir/";$dst_dir =~ s~/+~/~g;$dst_dir =~ s~/$~~;Verbose ("CopyFile: $src, $dst_dir, " . ($dst_name || ''));foreach $src ( &$resolver( $from_package, $src, \@platforms ) ){my $dst_fname = $dst_name ? $dst_name : StripDir($src);my $dst_file = "$dst_dir/$dst_fname";Verbose ("CopyFile: Copy $src, $dst_file" );## LinkFiles are special# They get concatenated to any existing LINKS File#if ( $isa_linkfile ){CatFile ( $src, "$dst_dir/.LINKS" );}else{mkpath( "$WorkDir$dst_dir", 0, 0775);unlink ("$WorkDir$dst_file");System ('cp','-f', $src, "$WorkDir$dst_file" );foreach my $lname ( @llist ){$lname = $dst_dir . '/' . $lname unless ( $lname =~ m ~^/~ );MakeSymLink( $dst_file ,$lname);}}## ConfigFiles are marked so that they can be handled by the debain installer#if ($isa_configFile){push @ConfigList, $WorkSubDir . $dst_file;}}}#-------------------------------------------------------------------------------# Function : ExtractTar## Description : Extract a tar file into a target directory# Useful for massive structures and those with embedded symlinks# Performs an implicit merge# Will create output root if it does not exist## Inputs : $srcTar - Source Tar file# $dst_dir - Within the output workspace# Options# --Source=Name - Source via Symbolic Name# --FromPackage - Source via package roots# --Strip=nn - Strip nn path elements from the dir## Returns :#sub ExtractTar{my ($srcTar, $dst_dir, @opts) = @_;my $userSrcTar = $srcTar;my $opt_source;my $opt_package;my $opt_strip;my $opt_base;my $from_interface;my $dname = StripDir($userSrcTar);my $errConfig = ErrorReConfig( prefix => "ExtractTar($dname): ");## Setup the basic options# May be altered as we parse user options#$dst_dir = $WorkDir . '/' . $dst_dir;$dst_dir =~ s~//~/~;## Scan and collect user options#foreach ( @opts ){Verbose2 ("$_");if ( m/^--Source=(.+)/ ) {Error ("Source directory can only be specified once")if ( defined $opt_source );$opt_source = $1;} elsif ( m/^--FromPackage/ ) {Error ("FromPackage can only be specified once")if ( defined $opt_package );$opt_package = 1;} elsif ( m/^--Strip=(\d+)$/i ) {Error ("Strip can only be specified once")if ( defined $opt_package );$opt_strip = $1;} else {Error ("Unknown option: $_" );}}## All options have been gathered. Now process some of them#Error ("Cannot use both --Source and --FromPackage: $srcTar") if ($opt_source && $opt_package);## Convert a symbolic path into a physical path#if ($opt_source){Verbose2 ("Determine Source: $opt_source");$opt_source = lc($opt_source);my %ExtractTarSymbolic = ('interfaceincdir' => $opt_interfaceincdir,'interfacelibdir' => $opt_interfacelibdir,'interfacebindir' => $opt_interfacebindir,'libdir' => $opt_libdir,'bindir' => $opt_bindir,'localincdir' => $opt_localincdir,'locallibdir' => $opt_locallibdir,'localbindir' => $opt_localbindir,'packagebindir' => $opt_pkgbindir,'packagelibdir' => $opt_pkglibdir,'packagepkgdir' => $opt_pkgpkgdir,'packagedir' => $opt_pkgdir,);if ( exists $ExtractTarSymbolic{$opt_source} ){$opt_base = $ExtractTarSymbolic{$opt_source};## If sourceing from interface, then follow# symlinks in the copy. All files will be links anyway#$from_interface = 1if ( $opt_source =~ m~^interface~ );}else{DebugDumpData ("ExtractTarSymbolic", \%ExtractTarSymbolic);Error ("Unknown Source Name: $opt_source" );}}## Locate the path within an external package#if ($opt_package){Verbose2 ("FromPackage: $srcTar");my @path;my @scanned;foreach my $entry ( getPackageList() ){my $base = $entry->getBase(3);next unless ( defined $base );push @scanned, $base;if ( -f $base . '/' . $srcTar ){push @path, $base;$from_interface = 1if ( $entry->{'TYPE'} eq 'interface' );}}if ( $#path < 0 ){Error ("Cannot find source dir in any package: $userSrcTar", @scanned);}Error ("Requested path found in mutiple packages: $userSrcTar",@path ) if ( $#path > 0 );$opt_base = pop @path;## If sourceing from interface, then follow symlinks in the copy.# All files will be links anyway## This is a very ugly test for 'interface'#$from_interface = 1if ( $opt_base =~ m~/interface/~ );}## Create the full source path# May be: from a package, from a known directory, from a local directory#$srcTar = $opt_base . '/' . $srcTar if ( $opt_base );$srcTar =~ s~//~/~g;Verbose ("$srcTar, $dst_dir");Error ("Tar File not found: $userSrcTar") unless ( -f $srcTar );## Create the output path if it does not exist#mkpath( $dst_dir ) unless -d $dst_dir;## Generate and execute the tar command#my @cmd = qw (tar -x --keep-old-files);push @cmd, '-f', $srcTar;push (@cmd, qw(-v --show-transformed-names)) if ($opt_verbose > 2);push (@cmd, "--strip=$opt_strip") if (defined $opt_strip);push @cmd, '-C', $dst_dir;System (@cmd);}#-------------------------------------------------------------------------------# Function : CopyDir## Description : Copy a directory to a target dir## Inputs : $src_dir - Local to the user# Symbolic Name# $dst_dir - Within the output workspace# Options# --Merge - Don't delete first# --Source=Name - Source via Symbolic Name# --FromPackage - Source via package roots# --FromPackage:Name - Source via specified package roots# --NoIgnoreDbgFiles - Do not ignore .dbg and .debug files in dir copy# --IfPresent - Not an error if the path cannot be found# --ConfFile - Mark transferred files as config files# --Flatten - Copy all to one directory# --FilterOut=xxx - Ignore files. DOS Wildcard# --FilterOutRe=xxx - Ignore files. Regular expression name# --FilterOutDir=xxx - Ignore directories. DOS Wilcard# --FilterOutDirRe=xxx - Ignore directories. Regular expression name# --SkipTLF - Ignore files in the Top Level Directory# --NoRecurse - Only process files in the Top Level Directory# --FilterIn=xxx - Include files. DOS Wildcard# --FilterInRe=xxx - Include files. Regular expression name# --FilterInDir=xxx - Include directories. DOS Wilcard# --FilterInDirRe=xxx - Include directories. Regular expression name## Returns :#sub CopyDir{my ($src_dir, $dst_dir, @opts) = @_;my $opt_base;my $from_interface = 0;my $ignoreDbg = 1;my $ignoreNoDir;my $user_src_dir = $src_dir;my $opt_source;my $opt_package;my $opt_package_name;my @fileList;my $isFiltered;return 1 unless ($ActiveSection);## Setup the basic copy options# May be altered as we parse user options#my %copyOpts;$copyOpts{'IgnoreDirs'} = ['.svn', '.git', '.cvs', '.hg'];$copyOpts{'Ignore'} = ['.gbedir', '_gbedir'];$copyOpts{'Log'} = 1 if ( $opt_verbose > 1 );$copyOpts{'DeleteFirst'} = 1;$dst_dir = $WorkDir . '/' . $dst_dir;$dst_dir =~ s~//~/~;## Scan and collect user options#foreach ( @opts ){Verbose2 ("CopyDir: $_");if ( m/^--Merge/ ) {$copyOpts{'DeleteFirst'} = 0;} elsif ( m/^--Source=(.+)/ ) {Error ("Source directory can only be specified once")if ( defined $opt_source );$opt_source = $1;} elsif ( m/^--FromPackage:(.+)/ ) {Error ("FromPackage can only be specified once")if ( defined $opt_package );$opt_package = 1;$opt_package_name = $1;} elsif ( m/^--FromPackage/ ) {Error ("FromPackage can only be specified once")if ( defined $opt_package );$opt_package = 1;} elsif ( m/^--NoIgnoreDbgFiles/ ) {$ignoreDbg = 0;} elsif ( m/^--IfPresent/ ) {$ignoreNoDir = 1;} elsif ( m/^--ConfFile/i ) {$copyOpts{'FileList'} = \@fileList;} elsif ( m/^--Flatten/i ) {$copyOpts{'Flatten'} = 1;} elsif ( m/^--FilterOut=(.+)/i ) {push (@{$copyOpts{'Ignore'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterOutRe=(.+)/i ) {push (@{$copyOpts{'IgnoreRE'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterOutDir=(.+)/i ) {push (@{$copyOpts{'IgnoreDirs'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterOutDirRe=(.+)/i ) {push (@{$copyOpts{'IgnoreDirsRE'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterIn=(.+)/i ) {push (@{$copyOpts{'Match'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterInRe=(.+)/i ) {push (@{$copyOpts{'MatchRE'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterInDir=(.+)/i ) {push (@{$copyOpts{'MatchDirs'}}, $1);$isFiltered = 1;} elsif ( m/^--FilterInDirRe=(.+)/i ) {push (@{$copyOpts{'MatchDirsRE'}}, $1);$isFiltered = 1;} elsif ( m/^--SkipTLF$/i ) {$copyOpts{'SkipTLF'} = 1;} elsif ( m/^--NoRecurse$/i ) {$copyOpts{'NoSubDirs'} = 1;} else {Error ("CopyDir: Unknown option: $_" );}}## All options have been gathered. Now process some of them#Error ("CopyDir: Cannot use both --Source and --FromPackage: $src_dir") if ($opt_source && $opt_package);## Convert a symbolic path into a physical path#if ($opt_source){Verbose2 ("CopyDir: Determine Source: $opt_source");$opt_source = lc($opt_source);my %CopyDirSymbolic = ('interfaceincdir' => $opt_interfaceincdir,'interfacelibdir' => $opt_interfacelibdir,'interfacebindir' => $opt_interfacebindir,'libdir' => $opt_libdir,'bindir' => $opt_bindir,'localincdir' => $opt_localincdir,'locallibdir' => $opt_locallibdir,'localbindir' => $opt_localbindir,'packagebindir' => $opt_pkgbindir,'packagelibdir' => $opt_pkglibdir,'packagepkgdir' => $opt_pkgpkgdir,'packagedir' => $opt_pkgdir,);if ( exists $CopyDirSymbolic{$opt_source} ){$opt_base = $CopyDirSymbolic{$opt_source};## If sourceing from interface, then follow# symlinks in the copy. All files will be links anyway#$from_interface = 1if ( $opt_source =~ m~^interface~ );}else{DebugDumpData ("CopyDirSymbolic", \%CopyDirSymbolic);Error ("CopyDir: Unknown Source Name: $opt_source" );}}## Locate the path within an external package#if ($opt_package){Verbose2 ("CopyDir: FromPackage: $src_dir");my @path;foreach my $entry ( getPackageList() ){## Locate the named package if specified#if (defined $opt_package_name) {next unless ($opt_package_name eq $entry->getName() || uc($opt_package_name) eq $entry->getUnifiedName() );}my $base = $entry->getBase(3);next unless ( defined $base );if ( folderHasFiles( $base . '/' . $src_dir) ){push @path, $base;$from_interface = 1if ( $entry->{'TYPE'} eq 'interface' );}}if ( $#path < 0 ){Error ("CopyDir: Cannot find source dir in any package: $user_src_dir") unless ($ignoreNoDir);Message ("CopyDir: Optional path not found: $user_src_dir");return;}Error ("CopyDir: Requested path found in mutiple packages: $user_src_dir",@path ) if ( $#path > 0 );$opt_base = pop @path;## If sourceing from interface, then follow symlinks in the copy.# All files will be links anyway## This is a very ugly test for 'interface'#$from_interface = 1if ( $opt_base =~ m~/interface/~ );}## Create the full source path# May be: from a package, from a known directory, from a local directory#$src_dir = $opt_base . '/' . $src_dir if ( $opt_base );$src_dir =~ s~//~/~g;$src_dir =~ s~/$~~;Verbose ("CopyDir: $src_dir, $dst_dir");unless ( -d $src_dir ){Error ("CopyDir: Directory not found: $user_src_dir") unless ($ignoreNoDir);Message ("CopyDir: Optional path not found: $user_src_dir");return;}## Continue to configure the copy options#push (@{$copyOpts{'Ignore'}}, '*.debug', '*.dbg') if $ignoreDbg;$copyOpts{'DuplicateLinks'} = 1 unless ( $from_interface );$copyOpts{'EmptyDirs'} = 1 unless ($isFiltered);## Transfer the directory#JatsCopy::CopyDir ( $src_dir, $dst_dir, \%copyOpts );## If requested, mark files as config files# Must remove the DebianWorkDir prefix#if(@fileList){Verbose ("Mark all transfered files as ConfFiles");my $removePrefix = length ($WorkDir);foreach my $file (@fileList){push @ConfigList, substr($file, $removePrefix);}}## Expand link files that may have been copied in#Verbose ("Locate LINKFILES in $WorkDir");ExpandLinkFiles();}#-------------------------------------------------------------------------------# Function : AddInitScript## Description : Add an Init Script to the target# Optionally create start and stop links## Inputs : $script - Name of the init script# $start - Start Number# $stop - Stop Number# Options:# --NoCopy - Don't copy the script, just add links# --Afc - Place in AFC init area# --FromPackage - Source is in a package# --Hibernate - Add hibernate symlink# --Resume - Add resume symlink# --Sk100Mode - Force SK100 Mode## Returns :#sub AddInitScript{my $no_copy;my $basedir = "";my @args;my $from_package = 0;my $hibernate = 0;my $resume = 0;my $sk100 = ($opt_target eq 'SK100');my $afcMode;return 1 unless ($ActiveSection);# This directive is only available on the VIX platforms# Kludgey test - at the moment#if ($opt_pkgarch =~ m~i386~) {Error ("AddInitScript is not supported on this platform");}## Process and Remove options#foreach ( @_ ){if ( m/^--NoCopy/ ) {$no_copy = 1;} elsif ( m/^--Afc/ ) {$basedir = "/afc";$afcMode = 1;} elsif ( m/^--FromPackage/ ) {$from_package = 1;} elsif ( m/^--Hibernate=(.*)/ ) {$hibernate = $1;} elsif ( m/^--Resume=(.*)/ ) {$resume = $1;} elsif ( m/^--SK100/i ) {$sk100 = 1;} elsif ( m/^--NoSK100/i ) {$sk100 = 0;} elsif ( m/^--/ ) {Error ("AddInitScript: Unknown option: $_");} else {push @args, $_;}}my( $script, $start, $stop ) = @args;Error ("No script file specified") unless ( $script );Warning("AddInitScript: No start or stop index specified") unless ( $start || $stop );Verbose ("AddInitScript: $script, " . ($start || 'No Start') . ", " . ($stop || 'No Stop'));Error ("Resume script not supported") if ($resume && !$sk100);Error ("Hibernate script not supported") if ($hibernate && !$sk100);Error ("AFC mode not supported on SK100 (@args)") if ( $sk100 && $afcMode );$script = ResolveFile($from_package, $script );my $tdir = $sk100 ? "/etc/init.d/init.vix.d" : "/etc/init.d/init.d";$tdir = catdir($basedir, $tdir);my $base = StripDir($script);unless ($no_copy) {CopyFile( $script, $tdir );SetFilePerms('a+rx', catfile($tdir,$base));}my $link;my $linkPath = $sk100 ? "/etc/init.d/init.vix.d/" : "/etc/init.d/";$linkPath = catdir($basedir, $linkPath) . '/';Verbose("InitScript: ", $base, $tdir, $linkPath);if ( $start ) {$link = sprintf ("${linkPath}S%2.2d%s", $start, $base );MakeSymLink( "$tdir/$base", $link);}if ( $stop ) {$link = sprintf ("${linkPath}K%2.2d%s", $stop, $base );MakeSymLink( "$tdir/$base", $link);}if ( $hibernate ) {$link = sprintf ("${linkPath}H%2.2d%s", $hibernate, $base );MakeSymLink( "$tdir/$base", $link);}if ( $resume ) {$link = sprintf ("${linkPath}R%2.2d%s", $resume, $base );MakeSymLink( "$tdir/$base", $link);}# In SK100 mode# init script must be placed in rc.local.d and must be sources and# a start stop resume or suspend function must be implemented.# For VIX these functions will call existing initscripts already package in# a vix folder.if ( $sk100 ) {my $rcLocal = "/etc/init.d/rc.local.d";my $rcLocalFile = catfile( $rcLocal, $base);my $rcWorkFile = catfile($WorkDir, $rcLocalFile );my $fh;CreateDir($rcLocal);Message ("creating service file: $rcLocalFile");unless (open $fh,'>', $rcWorkFile) {Error ("Failed to create Service file in $rcLocal, $!");}print $fh "#!/bin/sh\n# $base service file\n\n";print $fh "start() {\n [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base start\n}\n";print $fh "stop() {\n [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base stop\n}\n";print $fh "suspend() {\n [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base suspend\n}\n";print $fh "resume() {\n [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base resume\n}\n";close $fh;SetFilePerms('a+rx', $rcLocalFile);}return 1;}#-------------------------------------------------------------------------------# Function : CatFile## Description : Copy a file to the end of a file## Inputs : $src# $dst - Within the output workspace## Returns :#sub CatFile{my ($src, $dst) = @_;return 1 unless ($ActiveSection);$dst = $WorkDir . '/' . $dst;$dst =~ s~//~/~;Verbose ("CatFile: $src, $dst");$src = ResolveFile(0, $src );open (SF, '<', $src) || Error ("CatFile: Cannot open $src");open (DF, '>>', $dst) || Error ("CatFile: Cannot create:$dst");while ( <SF> ){print DF $_;}close (SF);close (DF);}#-------------------------------------------------------------------------------# Function : EchoFile## Description : Echo simple text to a file## Inputs : $file - Within the output workspace# $text## Returns :#sub EchoFile{my ($file, $text) = @_;return 1 unless ($ActiveSection);Verbose ("EchoFile: $file");$file = $WorkDir . '/' . $file;$file =~ s~//~/~;unlink $file;open (DT, ">", $file ) || Error ("Cannot create $file");print DT $text || Error ("Cannot print to $file");close DT;}#-------------------------------------------------------------------------------# Function : ConvertFiles## 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 : outPath - Output directory# flist - List of files in that directory# or# SearchOptions - Search options to find files# --Recurse# --NoRecurse# --FilterIn=xxx# --FilterInRe=xxx# --FilterOut=xxx# --FilterOutRe=xxx# Common options# --Dos# --Unix### Returns : 1#sub ConvertFiles{my @uargs;return 1 unless ($ActiveSection);my $lineEnding = "\n";my ($dosSet, $unixSet);my $search = JatsLocateFiles->new( '--NoRecurse' );## 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~^--Dos~) {$lineEnding = "\r\n";$dosSet = 1;} elsif ( m~^--Unix~) {$lineEnding = "\n";$unixSet = 1;} elsif ( m~^--~) {Error ("ConvertFiles: Unknown option: $_");} else {push @uargs, $_;}}## Process non-option arguments# - Base dir# - List of files#my ($outPath, @flist) = @uargs;Error ("ConvertFiles: Target Dir must be specified" ) unless ( $outPath );## Sanity Tests#Error ("ConvertFiles: --Dos and --Unix are mutually exclusive" ) if ( $dosSet && $unixSet );## Convert output path to physical path#my $topDir = catdir($WorkDir, $outPath);Verbose("ConvertFiles: topDir: $topDir");Error ("ConvertFiles: Path does not exist", $topDir) unless ( -e $topDir );Error ("ConvertFiles: Path is not a directory", $topDir) unless ( -d $topDir );## 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 ( @flist );@flist = $search->search($topDir);}Error ("ConvertFiles: No files specified") unless ( @flist );## Process all named files#foreach my $file ( @flist ){# this is our file that we want to clean.my ($ifileLoc) = "$topDir/$file";my ($tfileLoc) = "$topDir/$file\.tmp";Verbose("ConvertFiles: $file");# we will check to see if the file exists.#my $ifile;my $tfile;if ( -f "$ifileLoc" ){open ($ifile, "< $ifileLoc" ) orError("Failed to open file [$ifileLoc] : $!");open ($tfile, "> $tfileLoc" ) orError("Failed to open file [$tfileLoc] : $!");binmode $tfile;while ( <$ifile> ){s~[\n\r]+$~~; # Chompprint $tfile "$_" . $lineEnding;}}else{Error("ConvertFiles [$ifileLoc] does not exist.");}close $ifile;close $tfile;# lets replace our original file with the new one#if(File::Copy::move("$tfileLoc", "$ifileLoc")){Verbose2("ConvertFiles: Renamed [$tfileLoc] to [$ifileLoc] ...");}else{Error("ConvertFiles: Failed to rename file [$tfileLoc] to [$ifileLoc]: $!");}}return 1;}#----------------------------------------------------------------------------# Function : ReplaceTags## Description : This sub-routine is used to replace Tags in one or more files## Inputs : outPath - Output directory# flist - List of files in that directory# or# SearchOptions - Search options to find files# --Recurse# --NoRecurse# --FilterIn=xxx# --FilterInRe=xxx# --FilterOut=xxx# --FilterOutRe=xxx# Common options# --Tag=Tag,Replace### Returns : 1#sub ReplaceTags{return 1 unless ($ActiveSection);my @uargs;my $search = JatsLocateFiles->new( '--NoRecurse' );my @tagsList;my $tagSep = ',';my @tagOrder;my %tagData;## 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~^--Tag=(.*)~) {push @tagsList, $1;} elsif ( m~^--~) {Error ("ReplaceTags: Unknown option: $_");} else {push @uargs, $_;}}## Process non-option arguments# - Base dir# - List of files#my ($outPath, @flist) = @uargs;Error ("ReplaceTags: Target Dir must be specified" ) unless ( $outPath );## Sanity Tests#Error ("ReplaceTags: No tags specified" ) unless ( @tagsList );## Convert output path to physical path#my $topDir = catdir($WorkDir, $outPath);Verbose("ReplaceTags: topDir: $topDir");Error ("ReplaceTags: Path does not exist", $topDir) unless ( -e $topDir );Error ("ReplaceTags: Path is not a directory", $topDir) unless ( -d $topDir );## Convert Tags into pairs for latter use#my $sep = quotemeta ($tagSep );foreach my $tag ( @tagsList ){my ($tname,$tvalue) = split ( $sep, $tag, 2 );Error ("No tag value in: $tag" ) unless ( defined $tvalue );Error ("Duplicate Tag: $tname" ) if ( exists $tagData{$tname} );Verbose ("Tag: $tname :: $tvalue");push @tagOrder, $tname;$tagData{$tname} = $tvalue;}## 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 ("ReplaceTags: Cannot mix search options with named files") if ( @flist );@flist = $search->search($topDir);}Error ("ReplaceTags: No files specified") unless ( @flist );## Process all named files#foreach my $file ( @flist ){# this is our file that we want to clean.my ($ifileLoc) = "$topDir/$file";my ($tfileLoc) = "$topDir/$file\.tmp";Verbose("ReplaceTags: $file");# we will check to see if the file exists.#my $ifile;my $tfile;if ( -f "$ifileLoc" ){open ($ifile, "< $ifileLoc" ) orError("Failed to open file [$ifileLoc] : $!");open ($tfile, "> $tfileLoc" ) orError("Failed to open file [$tfileLoc] : $!");while ( <$ifile> ){s~[\n\r]+$~~; # Chomp## Perform tag replacement#foreach my $tag ( @tagOrder ){my $value = $tagData{$tag};if ( s~$tag~$value~g ){Verbose2("Replaced: $tag with $value");}}print $tfile "$_\n";}}else{Error("ReplaceTags [$ifileLoc] does not exist.");}close $ifile;close $tfile;# lets replace our original file with the new one#if(File::Copy::move("$tfileLoc", "$ifileLoc")){Verbose2("ReplaceTags: Renamed [$tfileLoc] to [$ifileLoc] ...");}else{Error("ReplaceTags: Failed to rename file [$tfileLoc] to [$ifileLoc]: $!");}}return 1;}#-------------------------------------------------------------------------------# Function : SetFilePerms## Description : Set file permissions on one or more files or directories# Use SetPermissions## Inputs : $perm - Perm Mask# @paths - List of paths/files to process# Options# --Recurse - Recurse subdirs## Returns :#sub SetFilePerms{return 1 unless ($ActiveSection);my @args;my $perms;my $recurse = 0;## Process and Remove options#foreach ( @_ ){if ( m/^--Recurse/ ) {$recurse = 1;} elsif ( m/^--/ ) {Error ("SetFilePerms: Unknown option: $_");} else {push @args, $_;}}$perms = shift @args;Error ("SetFilePerms: No Permissions" ) unless ( $perms );foreach my $path ( @args ){Verbose ("Set permissions; $perms, $path");my $full_path = $WorkDir . '/' . $path;if ( -f $full_path ){System ('chmod', $perms, $full_path );}elsif ( -d $full_path ){System ('chmod', '-R', $perms, $full_path ) if ($recurse);System ('chmod', $perms, $full_path ) unless ($recurse);}else{Warning("SetFilePerms: Path not found: $path");}}return 1;}#-------------------------------------------------------------------------------# Function : SetPermissions## Description : Called to set permissions of files/dirs in a directory structure.# With no options sets DirTag and all files/dirs in it to perms## Inputs : path - The directory tag to start setting permissions on# Options - See below## 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:# --RootOnly Only sets the permissions on the 'path' directory/file,# all other options ignored# --SkipRoot Does not set permissions on the 'path' directory/file,# obviously mutually exlusive with --RootOnly## Any option supported by JatsLocateFiles.# Some of these include:## --Recurse Recurse the directory tree. Does a depth first recurse so that all# dir entries are processed before the dir itself (default)# --NoRecurse Dont recurse# --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##------------------------------------------------------------------------------sub SetPermissions{return 1 unless ($ActiveSection);my ( $path, $filePerms, $dirPerms, $someDone );my ( $rootOnly, $skipRoot ) = ( 0, 0 );my $search = JatsLocateFiles->new( '--Recurse', '--DirsToo' );foreach ( @_ ){if ( m/^--Perms=(.*)/ ) {$filePerms = $1;$dirPerms = $1;} elsif (m/^--FilePerms=(.*)/ ) {$filePerms = $1;} elsif ( m/^--DirPerms=(.*)/ ) {$dirPerms = $1;} elsif ( m/^--RootOnly/ ) {$rootOnly = 1;} elsif ( m/^--SkipRoot/ ) {$skipRoot = 1;} elsif ( m/^--Filter/ && $search->option( $_ ) ) {Verbose2 ("Search Option: $_" );} elsif ( m/^--Recurse|--NoRecurse/ && $search->option( $_ ) ) {Verbose2 ("Search Option: $_" );} elsif (m/^--/ ) {Error ("SetPermissions: Unknown option: $_");} else {Error("SetPermissions 'path' already set", "Path: $_") if ( $path );$path = $_;}}## Sanity test#Error("SetPermissions called with out a 'path' parameter") if ( !defined($path) );Error("SetPermissions called with out any Permissions specified") if ( !defined($filePerms) && !defined($dirPerms) );Error("SetPermissions: Options --RootOnly & --SkipRoot are mutually exclusive" ) if ( $rootOnly && $skipRoot );# Convert the target directory name into a physical path# User specifies '/' as the root of the image# User specifies 'name' as relateve to the root of the image#my $topDir = $WorkDir . '/' . $path;$topDir =~ s~/+$~~;Verbose("SetPermissions: Called with options " . join(", ", @_));## Only set perms on the root directory# This is a trivial operation#if ( $rootOnly ){$someDone += chmodItem( $topDir, $filePerms, $dirPerms );}else{## Create a list of files/dirs to process#my @elements = $search->search( $topDir );foreach my $dirEntry ( @elements ){my $fullPath = "$topDir/$dirEntry";# A dir and we dont have dirperms, so skipif ( -d $fullPath && !defined($dirPerms) ){Verbose2("SetPermissions: Skipping dir $fullPath as we have no dir permissions");next;}# A file and we dont have fileperms, so skipif ( -f $fullPath && !defined($filePerms) ){Verbose2("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 recursingif ( -f $fullPath || -d $fullPath ){$someDone += chmodItem( $fullPath, $filePerms, $dirPerms );}else{Warning("SetPermissions: Skipping $fullPath as its not a file or directory");}}## Process the topDir# May not be modified if --SkipRoot has been requested#if ( !$skipRoot && -e $topDir ){$someDone += chmodItem( $topDir, $filePerms, $dirPerms );}}# Final warning#Warning ("SetPermissions: No files located", "Args: @_") unless ( $someDone );}#************ INTERNAL USE ONLY **********************************************# Function : chmodItem## Description : Internal# chmod a file or a folder## Inputs : item - Item to mod# filePerms - File perms# dirPerms - dire perms## Returns : 1 - Item modified# 0 - Item not modified##************ INTERNAL USE ONLY **********************************************sub chmodItem{my ($item, $filePerms, $dirPerms) = @_;if ( -d $item && defined $dirPerms){Verbose("SetPermissions: $dirPerms : $item");System ('chmod', $dirPerms, $item );return 1;}if ( -f $item && defined $filePerms){Verbose("SetPermissions: $filePerms : $item");System ('chmod', $filePerms, $item );return 1;}return 0;}#-------------------------------------------------------------------------------# Function : CreateDir## Description : Create a directory within the target workspace## Inputs : $path - Name of the target directory# @opts - Options# --Owner - Tells RPM Builder that this package. Owns this directory## Returns : Nothing#sub CreateDir{my ($path, @opts) = @_;return 1 unless ($ActiveSection);Verbose ("Create Dir: $path");my $owner = 0;foreach ( @opts) {if (m~^--Owner~i ) {$owner = 1;} else {ReportError ("SetBaseDir: Unknown option: $_");}}ErrorDoExit();$path =~ s~^/+~~;$path = '/' . $path;$OwnedDirs{$path} = $owner if $owner;mkpath( $WorkDir . $path );}#-------------------------------------------------------------------------------# Function : RpmSetDefAttr## Description : RPM only: Set the defAttr values## Inputs : Expect 4 or less argument# The default permissions, or "mode" for files.# The default user id.# The default group id.# The default permissions, or "mode" for directories.#sub RpmSetDefAttr{return 1 unless ($ActiveSection);return 1 unless $opt_rpm;my @args = @_;Error ("RpmSetDefAttr: Expecting 4 arguments") if (scalar @args ne 4);@RpmDefAttr = @_;return 1;}#-------------------------------------------------------------------------------# Function : RpmSetAttr## Description : RPM Only : Specify specific file attributes## Inputs : $file - file to target# $mode - File mode to place on the file (optional)# $user - user name to place on the file (optional)# $group - group name to place eon the file (optional)#sub RpmSetAttr{return 1 unless ($ActiveSection);return 1 unless $opt_rpm;my ($file, $mode, $user, $group, @extra) = @_;Error ("RpmSetAttr: Too many arguments") if @extra;## Validate the file#$file = '/' . $file;$file =~ s~//~/~g;my $full_path = $WorkDir . $file;Error ("RpmSetAttr: File not found: $WorkSubDir$file") unless (-x $full_path );my @data;$data[0] = $WorkSubDir . $file;$data[1] = $mode || '-';$data[2] = $user || '-';$data[3] = $group ||'-';push @RpmAttrList, \@data;return 1;}#-------------------------------------------------------------------------------# Function : IsProduct# IsPlatform# IsTarget# IsVariant# IsAlias# IsDebian# IsRpm# IsTar# IsZip## Description : This function allows some level of control in the# packaging scripts. It will return true if the current# product is listed.## Ugly after thought## Intended use:# Xxxxxx(...) if (IsProduct( 'aaa',bbb' );## Inputs : products - a list of products to compare against## Returns : True if the current build is for one of the listed products#sub IsProduct{foreach ( @_ ){return 1 if ( $opt_product eq $_ );}return 0;}sub IsPlatform{foreach ( @_ ){return 1 if ( $opt_platform eq $_ );}return 0;}sub IsTarget{foreach ( @_ ){return 1 if ( $opt_target eq $_ );}return 0;}sub IsVariant{foreach ( @_ ){return 1 if ( $opt_variant eq $_ );}return 0;}sub IsAlias{## Get the aliases from the build info# This function was introduced late so its not always available#Error("IsAlias not supported in this version of JATS")unless (defined &ReadBuildConfig::getAliases);## Create an hash of aliases to simplify testing# Do it once and cache the results#unless (%opt_aliases) {%opt_aliases = map { $_ => 1 } getAliases();}foreach ( @_ ){return 1 if ( exists $opt_aliases{$_} );}return 0;}sub IsDebian(){return $opt_debian ? 1 : 0;}sub IsRpm(){return $opt_rpm ? 1 : 0;}sub IsTar(){return $opt_tarFile ? 1 : 0;}sub IsZip(){return $opt_zipFile ? 1 : 0;}#-------------------------------------------------------------------------------# Function : PackageVersion## Description : Return the version of the named package## Inputs : pkgName - Name of the package# Options# --format=SomeString. The text replacements# {VERSION}# {VERSIONNUMVER}# {PROJECT}# {NAME}# {TYPE}# {ARCH}## Returns : A string#sub PackageVersion{my ($pkgName, @args) = @_;my ($version, $versionNumber, $project, $format);foreach ( @args){if (m~^--format=(.+)~i) {$format = $1} else {Error ("PackageVersion: Unknown option: $_")}}foreach my $entry ( getPackageList() ){if ($entry->getName() eq $pkgName ) {$version = $entry->getVersion();($versionNumber = $version ) =~ s~\.[^.]+$~~;($project = $version ) =~ s~.*\.~~;last;}}Error ("PackageVersion: $pkgName is not a dependent package") unless defined $version;## Format the string#if ($format) {$format =~ s~{NAME}~$pkgName~g;$format =~ s~{VERSION}~$version~g;$format =~ s~{VERSIONNUMBER}~$versionNumber~g;$format =~ s~{PROJECT}~$project~g;$format =~ s~{TYPE}~$opt_type~g;$format =~ s~{ARCH}~$opt_pkgarch~g;$version = $format;}return $version;}#************ INTERNAL USE ONLY **********************************************# Function : FindFiles## Description : Locate files within a given dir tree## Inputs : $root - Base of the search# $match - Re to match## Returns : A list of files that match##************ INTERNAL USE ONLY **********************************************my @FIND_LIST;my $FIND_NAME;sub FindFiles{my ($root, $match ) = @_;Verbose2("FindFiles: Root: $root, Match: $match");## Becareful of closure, Must use globals#@FIND_LIST = ();$FIND_NAME = $match;File::Find::find( \&find_files, $root);## Find callback program#sub find_files{my $item = $File::Find::name;return if ( -d $File::Find::name );return unless ( $_ =~ m~$FIND_NAME~ );push @FIND_LIST, $item;}return @FIND_LIST;}#-------------------------------------------------------------------------------# Function : CalcRelPath## Description : Return the relative path to the current working directory# as provided in $Cwd## Inputs : $Cwd - Base dir# $base - Path to convert## Returns : Relative path from the $Cwd#sub CalcRelPath{my ($Cwd, $base) = @_;my @base = split ('/', $base );my @here = split ('/', $Cwd );my $result;Debug("RelPath: Source: $base");return $base unless ( $base =~ m~^/~ );## Remove common bits from the head of both lists#while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] ){shift @base;shift @here;}## Need to go up some directories from here and then down into base#$result = '../' x ($#here + 1);$result .= join ( '/', @base);$result = '.' unless ( $result );$result =~ s~//~/~g;$result =~ s~/$~~;Debug("RelPath: Result: $result");return $result;}#-------------------------------------------------------------------------------# Function : folderHasFiles## Description : Detect empty folders## Inputs : dirname - Path to examine## Returns : TRUE - Is a folder and it has files#sub folderHasFiles {my $dirname = shift;my $rv = 0;my $dh;return 0 unless -d $dirname;opendir($dh, $dirname) || return 0;while (my $file = readdir $dh){next unless (defined $file);next if ($file eq "." || $file eq "..");$rv = 1;last;}closedir $dh;return $rv;}#-------------------------------------------------------------------------------# Function : ExpandLinkFiles## Description : Look for .LINK files in the output image and expand# the links into softlinks## Inputs : None# The routine works on the $WorkDir directory tree## Returns : Nothing# Will remove .LINKS files that are processed#sub ExpandLinkFiles{return 1 unless ($ActiveSection);foreach my $linkfile ( FindFiles( $WorkDir, ".LINKS" )){next if ( $linkfile =~ m~/\.svn/~ );my $BASEDIR = StripFileExt( $linkfile );$BASEDIR =~ s~^$WorkDir/~~;Verbose "Expand links: $BASEDIR";open (LF, "<", $linkfile ) || Error ("Cannot open link file: $linkfile" );while ( <LF> ){chomp;next if ( m~^#~ );next unless ( $_ );my ($link, $file) = split;MakeSymLink($file ,"$BASEDIR/$link", '--NoDotDot' );}close (LF);unlink $linkfile;}}#************ INTERNAL USE ONLY **********************************************# Function : ResolveFile## Description : Determine where the source for a file is# Will look in (default):# Local directory# Local Include# Or (FromPackage)# Our Package directory# Interface directory (BuildPkgArchives)# Packages (LinkPkgArchive)## Will scan 'parts' subdirs## Inputs : $from_package - 0 - Local File# $file# $refPlatforms - Not used## Returns : Path##************ INTERNAL USE ONLY **********************************************sub ResolveFile{my ($from_package, $file,$refPlatforms) = @_;my $wildcard = ($file =~ /[*?]/);my @path;## Determine the paths to search#if ( $from_package ){unless ( @ResolveFileList ){push @ResolveFileList, $opt_pkgdir;foreach my $entry ( getPackageList() ){push @ResolveFileList, $entry->getBase(3);}}@path = @ResolveFileList;}else{@path = ('.', $opt_localincdir);}# Determine a full list of 'parts' to search# Default: Provided within the build information# User : Can provide a listmy @parts = getPlatformPartsList($refPlatforms);my @done;foreach my $root ( @path ){foreach my $subdir ( @parts ){my $sfile;$sfile = "$root/$subdir/$file";$sfile =~ s~//~/~g;$sfile =~ s~^./~~g;Verbose2("LocateFile: $sfile, $root, $subdir");if ( $wildcard ){push @done, glob ( $sfile );}else{push @done, $sfile if ( -f $sfile || -l $sfile )}}}DisplaySearchPath('ResolveFile', $file, \@parts, undef, \@path) unless (@done) ;Warning ("ResolveFile: Multiple instances of file found. Only first is used", @done)if ( $#done > 0 && ! $wildcard && !wantarray );return wantarray ? @done : $done[0];}#-------------------------------------------------------------------------------# Function : ResolveBinFile## Description : Determine where the source for a BIN file is# Will look in (default):# Local directory# Local Include# Or (FromPackage)# Our Package directory# Interface directory (BuildPkgArchives)# Packages (LinkPkgArchive)# Will scan 'parts' subdirs (default)# May scan user-provided parts (cross platform packaging)## Inputs : $from_package - 0 - Local File# $file# $refPlatforms - (optional) Ref to an array of platforms to scan## Returns : Path#sub ResolveBinFile{my ($from_package, $file, $refPlatforms) = @_;my @path;my @types;my $wildcard = ($file =~ /[*?]/);## Determine the paths to search#if ( $from_package ){unless ( @ResolveBinFileList ){push @ResolveBinFileList, $opt_pkgdir . '/bin';foreach my $entry ( getPackageList() ){if ( my $path = $entry->getBase(3) ){$path .= '/bin';push @ResolveBinFileList, $path if ( -d $path );}}}@path = @ResolveBinFileList;@types = ($opt_type, '');}else{@path = ($opt_bindir, $opt_localbindir);@types = '';}## Determine a full list of 'parts' to search# Default: Provided within the build information# User : Can provide a list#my @parts = getPlatformPartsList($refPlatforms);my @done;foreach my $root ( @path ){foreach my $subdir ( @parts ){foreach my $type ( @types ){my $sfile;$sfile = "$root/$subdir$type/$file";$sfile =~ s~//~/~g;Verbose2("LocateBinFile: $sfile");if ( $wildcard ){foreach ( glob ( $sfile ) ){# Ignore .dbg (vix) and .debug (qt) files.next if ( m~\.dbg$~ );next if ( m~\.debug$~ );push @done, $_;}}else{push @done, $sfile if ( -f $sfile || -l $sfile )}}}}## Pretty display the search path - on error# Will not return.#DisplaySearchPath('ResolveBinFile', $file, \@parts, \@types, \@path) unless (@done) ;if ( $#done > 0 && ! $wildcard ){Warning ("ResolveBinFile: Multiple instances of file found. Only first is used", @done);splice (@done, 1);}return wantarray ? @done : $done[0];}#-------------------------------------------------------------------------------# Function : ResolveLibFile## Description : Determine where the source for a LIB file is# Will look in (default):# Local directory# Local Include# Or (FromPackage)# Our Package directory# Interface directory (BuildPkgArchives)# Packages (LinkPkgArchive)# Will scan 'parts' subdirs## Inputs : $from_package - 0:Local File# $file - Basename for a 'realname'# Do not provide 'lib' or '.so' or version info# May contain embedded options# --Dll - Use Windows style versioned DLL# --VersionDll - Use the versioned DLL# --3rdParty - Use exact name provided# $refPlatforms - Ref to an array of platforms to scan## Returns : Path#sub ResolveLibFile{my ($from_package, $file, $refPlatforms) = @_;my $wildcard = ($file =~ /[*?]/);my @options;my $num_dll;my @types;my @path;## Extract options from file#$num_dll = 0;($file, @options) = split ( ',', $file);foreach ( @options ){if ( m/^--Dll/ ) {$num_dll = 1;} elsif ( m/^--VersionDll/ ) {$num_dll = 2;} elsif ( m/^--3rdParty/ ) {$num_dll = 3;} else {Error ("Unknown suboption to ResolveLibFile: $_" );}}## Determine the paths to search#if ( $from_package ){unless ( @ResolveLibFileList ){push @ResolveLibFileList, $opt_pkgdir . '/lib';foreach my $entry ( getPackageList() ){push @ResolveLibFileList, $entry->getLibDirs(3);}}@path = @ResolveLibFileList;}else{@path = ($opt_libdir, $opt_locallibdir);}# Determine a full list of 'parts' to search# Default: Provided within the build information# User : Can provide a listmy @parts = getPlatformPartsList($refPlatforms);@types = ( $opt_type, '');my @done;foreach my $root ( @path ){foreach my $type ( @types ){foreach my $subdir ( @parts ){my $sfile;my $exact;if ( $num_dll == 2 ) {$sfile = $file . $type . '.*.dll' ;} elsif ( $num_dll == 1 ) {$sfile = $file . $type . '.dll' ;$exact = 1;} elsif ( $num_dll == 3 ) {$sfile = $file;$exact = 1;} else {$sfile = "lib" . $file . $type . '.so.*';}$sfile = "$root/$subdir/$sfile";$sfile =~ s~//~/~g;Verbose2("LocateLibFile: $sfile");if ( $exact ){UniquePush(\@done, $sfile) if ( -f $sfile || -l $sfile );}elsif ($num_dll){push @done, glob ( $sfile );}else{## Looking for .so files# Filter out the soname so files# Assume that the soname is shorter than the realname# Ignore .dbg (vix) and .debug (qt) files.#my %sieve;foreach ( glob ( $sfile ) ){next if ( m~\.dbg$~ );next if ( m~\.debug$~ );m~(.*\.so\.)([\d\.]*\d)$~;if ( $1 ){my $file = $1;my $len = exists $sieve{$file} ? length($sieve{$file}) : 0;$sieve{$file} = $_if ( $len == 0 || length($_) > $len );}}push @done, values %sieve;}}}}DisplaySearchPath('ResolveLibFile', $file, \@parts, \@types, \@path) unless (@done) ;if ( $#done > 0 && ! $wildcard ){Warning ("ResolveLibFile: Multiple instances of file found. Only first is used", @done);splice (@done, 1);}return wantarray ? @done : $done[0];}#-------------------------------------------------------------------------------# Function : ResolveDebPackage## Description : Determine where the source for a Debian Package is# Will look in (default):# Local directory# Local Include# Or (FromPackage)# Our Package directory# Interface directory (BuildPkgArchives)# Packages (LinkPkgArchive)## Inputs : $from_package - 0:Local File# $baseName - Basename for a 'DebianPackage'# Do not provide version info, architecture or suffix# May contain embedded options# --Arch=XXX - Specify alternate architcuture# --Product=YYYY - Specify product family# --Debug - Use alternate build type# --Prod - Use alternate build type# $refPlatforms - Ref to an array of platforms to scan## Returns : Path#sub ResolveDebPackage{my ($from_package, $file, $refPlatforms) = @_;my @path;my $arch;my $product;my $buildType;my @types;my $baseName;my @options;## Extract options from file#($baseName, @options) = split ( ',', $file);foreach ( @options ){if ( m/^--Arch=(.+)/ ) {$arch=$1;} elsif ( m/^--Product=(.+)/ ) {$product = $1;} elsif ( m/^--Debug/ ) {Error ("ResolveDebPackage: Cannot specify --Prod and --Debug") if defined $buildType;$buildType = 'D';} elsif ( m/^--Prod/ ) {Error ("ResolveDebPackage: Cannot specify --Prod and --Debug") if defined $buildType;$buildType = 'P';} else {Error ("Unknown suboption to ResolveDebPackage: $_" );}}## Insert defaults#$buildType = $opt_type unless ($buildType);$arch = $opt_target unless ($arch);## Determine the paths to search#if ( $from_package ){unless ( @ResolveDebFileList ){push @ResolveDebFileList, $opt_pkgdir, $opt_pkgdir . '/bin';foreach my $entry ( getPackageList() ){if ( my $path = $entry->getBase(3) ){push @ResolveDebFileList, $path if ( -d $path );$path .= '/bin';push @ResolveDebFileList, $path if ( -d $path );}}}@path = @ResolveDebFileList;@types = ($buildType, '');}else{@path = ($opt_bindir, $opt_localbindir);@types = ($buildType, '');}## The debian package name is# In packages BIN dir# (BaseName)_VersionString(_Product)(_Arch).deb## In root of package# (BaseName)_VersionString(_Product)(_Arch)(_Type).deb### The package may be found in# Package Root# Package bin directory#$file = $baseName . '_*';if (defined $product) {$file .= ( '_' . $product)}$file .= '_' . $arch;# Determine a full list of 'parts' to search# Default: Provided within the build information# User : Can provide a listmy @parts = getPlatformPartsList($refPlatforms);my @done;foreach my $root ( @path ){foreach my $subdir ( @parts ){foreach my $type ( @types ){my $sfile;$sfile = "$root/$subdir$type/$file";$sfile =~ s~//~/~g;foreach my $type2 ( @types ){my $tfile = $sfile;$tfile .= '_' . $type2 if $type2;$tfile .= '.deb';Verbose2("ResolveDebPackage: $tfile");foreach ( glob ( $tfile ) ){push @done, $_;}}}}}DisplaySearchPath('ResolveDebPackage', $file, \@parts, \@types, \@path) unless (@done) ;if ( $#done > 0 ){Error ("ResolveDebPackage: Multiple instances of Package found.", @done);}return wantarray ? @done : $done[0];}#-------------------------------------------------------------------------------# Function : prettyArray## Description : Generate a quoted string from an array## Inputs : Array Ref## Returns : A string#sub prettyArray{my ($arrayRef) = @_;return join(',', map { qq!"$_"! } @{$arrayRef})}#-------------------------------------------------------------------------------# Function : DisplaySearchPath## Description : Pretty display of the search path# Error display## Inputs : $name - Function Name# $file - Base filename being searched# $parts - Ref to array of parts searched# $types - Ref to array of types searched - may be undef# $path - Ref to array of paths searched## Returns : Will not return#sub DisplaySearchPath{my ($name, $file, $parts, $types, $path) = @_;my @text;push @text, $name . ': File not found: ' . $file;push @text, 'Search Platforms: ' . prettyArray($parts);push @text, 'Search Types: ' . prettyArray($types) if defined $types;push @text, 'Search Path:', @$path;Error (@text);}#-------------------------------------------------------------------------------# Function : getPlatformPartsList## Description : Determine a full list of 'parts' to search# Default: Provided within the build information# User : Can provide a list## Inputs : $refPlatforms - Ref to an array of user provided platforms# If provided will override the internal list## Returns : An array#sub getPlatformPartsList{my ($refPlatforms) = @_;my @parts;if ($refPlatforms && scalar @{$refPlatforms}) {@parts = @{$refPlatforms};} else {@parts = getPlatformParts ();}push @parts, '';return @parts;}#-------------------------------------------------------------------------------# Function : AUTOLOAD## Description : Intercept unknown user directives and issue a nice error message# This is a simple routine to report unknown user directives# It does not attempt to distinguish between user errors and# programming errors. It assumes that the program has been# tested. The function simply report filename and line number# of the bad directive.## Inputs : Original function arguments ( not used )## Returns : This function does not return#our $AUTOLOAD;sub AUTOLOAD{my $fname = $AUTOLOAD;$fname =~ s~^main::~~;my ($package, $filename, $line) = caller;my $prefix;## Some directives are applicable to Rpm and/or Debian only# If a directive starts with Rpm, Debian or All, then invoke# the underlying directive iff we are process a Debian/Rpm file## The underlying directive will start with MULTI_# It will be called with the first argument being the name of the function# that it is being called as.#$fname =~ m~^(Rpm|Debian|All)(.*)~;if (defined $1) {my $type = $1;my $tfname = 'MULTI_' . $2;my $fRef = \&{$tfname};if (defined &{$tfname}) {if ($type eq 'Rpm') {$fRef->($fname, @_) if $opt_rpm;} elsif ($type eq 'Debian') {$fRef->($fname, @_) if $opt_debian;} elsif ($type eq 'All') {$fRef->($fname, @_);}return 1;}}Error ("Directive not known or not allowed in this context: $fname","Directive: $fname( @_ );","File: " . RelPath($filename) . ", Line: $line" );}1;