Rev 1523 | Rev 3921 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### Copyright (C) 2007 ERG Limited, All rights reserved## Module name : jats.sh# Module type : Makefile system# Compiler(s) : n/a# Environment(s): jats## Description : This program is invoked by the MakeDebianPackage# directive, that is a part of this package## The program will use a user-provided script in order# to create a Debian 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 configuration scaripts that# will be embedded in the package.## This program will:# Construct a filesystem image under control of the directives# within the user script## Massage the Debian control file## Create a Debian Package## Transfer it to the users 'BIN' directory, where it is# available to be packaged.## Summary of directives available to the user-script:# AddInitScript - Add an init script# CatFile - Append to a file# CopyDir - Copy directory tree# CopyFile - Copy a file# CopyBinFile - Copy an executable file# CopyLibFile - Copy a library file# CreateDir - Create a directory# DebianFiles - Specify control and script files# EchoFile - Place text into a file# MakeSymLink - Create a symbolic link# PackageDescription - Specify the package description# SetFilePerms - Set file permissions# SetVerbose - Control progress display# IsProduct - Flow control# IsPlatform - Flow control# IsTarget - Flow control# IsVariant - Flow control## Thoughts for expansion:# ConvertFile - Option to convert file(s) to Unix Text# ReplaceTags - Replace Tags on target file# 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##......................................................................#require 5.006_001;use strict;use warnings;use Getopt::Long;use File::Path;use File::Copy;use File::Find;use JatsSystem;use FileUtils;use JatsError;use ReadBuildConfig;use JatsCopy (); # Don't import anything## Globals#my $DebianWorkDirBase; # Workspacemy $DebianWorkDir; # Dir to create file system image within## 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_platform;my $opt_type;my $opt_buildname;my $opt_buildversion;my $opt_interfacedir;my $opt_target;my $opt_product;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_output;my $opt_name;my $opt_variant;## Options derived from script directives#my $opt_control = '';my $opt_prerm = '';my $opt_postrm = '';my $opt_preinst = '';my $opt_postinst = '';my $opt_description;## Globals#my @ResolveFileList; # Cached Package File Listmy @ResolveBinFileList; # Cached PackageBin File Listmy @ResolveLibFileList; # Cached PackageLib File List#-------------------------------------------------------------------------------# 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,"BuildVersion=s" => \$opt_buildversion,"Platform=s" => \$opt_platform,"Target=s" => \$opt_target,"Product=s" => \$opt_product,"DebianPackage=s" => \$opt_package_script,"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,"Output=s" => \$opt_output,"Variant:s" => \$opt_variant,"Name=s" => \$opt_name,);$opt_verbose++ unless ( $opt_vargs eq '@' );ErrorConfig( 'name' => 'DebianUtils','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 ("InterfaceDir not set") unless ( $opt_interfacedir );Error ("Target not set") unless ( $opt_target );Error ("Product not set") unless ( $opt_product );Error ("DebianPackage not set") unless ( $opt_package_script );Error ("Ouput File not set") unless ( $opt_output );Error ("Build Name not set") unless ( $opt_name );## Clean up the build name# Match any work done in the MakeDebianPackage directive#$opt_buildname =~ s~_~-~g;## Read in relevent config information#ReadBuildConfig ($opt_interfacedir, $opt_platform, '--NoTest' );## Build the package image in a directory based on the target being created#$DebianWorkDirBase = "$opt_platform$opt_type.image";$DebianWorkDir = "$DebianWorkDirBase/$opt_name";## Configure the System command to fail on any error#SystemConfig ( ExitOnError => 1 );## Extract the 'name' of the package from the output path# Display purposes only#my $DebianPkgName = StripDirExt($opt_output);## Display variables used#Message "=Building Debian Package =============================================";Message "Build $opt_name";Message " Package: $opt_buildname";Message " Variant: $opt_variant" if ($opt_variant);Message " Version: $opt_buildversion";Message " Building for: $opt_platform, $opt_target";Message " Product: $opt_product";Message " Type: $opt_type";Verbose " Verbose: $opt_verbose";Verbose " InterfaceDir: $opt_interfacedir";Message " Package: $DebianPkgName";Message "======================================================================";## Perform Clean up# Invoked during "make clean" or "make clobber"#if ( $opt_clean ){Message ("Remove packaging directory: $DebianWorkDir");## Remove the directory for this package# Remove the general work dir - if all packages have been cleaned#rmtree( $DebianWorkDir );rmdir( $DebianWorkDirBase );rmtree ($opt_output) if ( -f $opt_output );exit;}## 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( $DebianWorkDir );mkpath( $DebianWorkDir );my $perm = (stat $DebianWorkDir)[2] & 0777;chmod ( $perm & 0777, $DebianWorkDir );## Invoke the user script to do the hard work#do $opt_package_script;## Complete the building of the package#BuildDebianPackage ();Message ("Created Debian Package");}#-------------------------------------------------------------------------------# 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 ( $opt_control || $opt_description );## Convert the FileSystem Image into a Debian Package# Insert Debian control files#Verbose ("Copy in the Debian Control Files");mkdir ( "$DebianWorkDir/DEBIAN" );CopyFile ( $opt_prerm, "/DEBIAN", "prerm" ) if $opt_prerm;CopyFile ( $opt_postrm, "/DEBIAN", "postrm" ) if $opt_postrm;CopyFile ( $opt_preinst, "/DEBIAN", "preinst" ) if $opt_preinst;CopyFile ( $opt_postinst, "/DEBIAN", "postinst" ) if $opt_postinst;UpdateControlFile ($opt_control );System ( 'chmod', '-R', 'a+rx', "$DebianWorkDir/DEBIAN" );System ( 'build_dpkg.sh', '-b', $DebianWorkDir);System ( 'mv', '-f', "$DebianWorkDir.deb", $opt_output );System ("build_dpkg.sh", '-I', $opt_output) if (IsVerbose(1));}#-------------------------------------------------------------------------------# Function : UpdateControlFile## Description : Update the Debian 'control' file to fix up varoius 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 UpdateControlFile{my($src) = @_;my $dst = "$DebianWorkDir/DEBIAN/control";unless ( $src ){CreateControlFile();return;}Verbose ("UpdateControlFile: $dst" );$src = ResolveFile( 0, $src );open (SF, '<', $src) || Error ("UpdateControlFile: Cannot open $src");open (DF, '>', $dst) || Error ("UpdateControlFile: Cannot create:$dst");while ( <SF> ){s~\s*$~~;if ( m~^Package:~ ) {$_ = "Package: $opt_buildname";} elsif ( m~^Version:~ ) {$_ = "Version: $opt_buildversion";} elsif ( m~^Architecture:~ ) {$_ = "Architecture: $opt_platform";} elsif ( $opt_description && m~^Description:~ ) {$_ = "Description: $opt_description";}print DF $_ , "\n";}close (SF);close (DF);}#-------------------------------------------------------------------------------# Function : CreateControlFile## Description : Craete a basic debian control file## Inputs : Uses global variables## Returns :#sub CreateControlFile{my $dst = "$DebianWorkDir/DEBIAN/control";Verbose ("CreateControlFile: $dst" );open (DF, '>', $dst) || Error ("CreateControlFile: Cannot create:$dst");print DF "Package: $opt_buildname\n";print DF "Version: $opt_buildversion\n";print DF "Section: main\n";print DF "Priority: standard\n";print DF "Architecture: $opt_platform\n";print DF "Essential: yes\n";print DF "Maintainer: ERG\n";print DF "Description: $opt_description\n";close (DF);}#-------------------------------------------------------------------------------# Function : SetVerbose## Description : Set the level of verbosity# Display activity## Inputs : Verbosity level# 0 - Use makefile verbosity (Default)# 1..2## Returns :#sub SetVerbose{my ($level) = @_;$level = $opt_verbose unless ( $level );$opt_verbose = $level;ErrorConfig( 'verbose' => $level);}#-------------------------------------------------------------------------------# Function : DebianFiles## Description : Name Debian builder control files# May be called multiple times## Inputs : Options# --Control=file# --PreRm=file# --PostRm=file# --PreInst=file# --PostInst=file## Returns : Nothing#sub DebianFiles{## Exctact names#Verbose ("Specify Debian Control Files and Scripts");foreach ( @_ ){if ( m/^--Control=(.+)/ ) {$opt_control = $1;} elsif ( m/^--PreRm=(.+)/ ) {$opt_prerm = $1;} elsif ( m/^--PostRm=(.+)/ ) {$opt_postrm = $1;} elsif ( m/^--PreInst=(.+)/ ) {$opt_preinst = $1;} elsif ( m/^--PostInst=(.+)/ ) {$opt_postinst = $1;} else {Error ("DebianFiles: Unknown option: $_");}}}#-------------------------------------------------------------------------------# Function : PackageDescription## Description : Specify the Package Description# Keep it short## Inputs : $description## Returns :#sub PackageDescription{($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;## 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 = $DebianWorkDir . '/' . $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{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{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{CopyFileCommon( \&ResolveLibFile, @_ );}#-------------------------------------------------------------------------------# 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# --SoftLink=xxxx# --LinkFile=xxxx## Returns :#sub CopyFileCommon{my $from_package = 0;my $isa_linkfile = 0;my @llist;my @args;## Parse options#foreach ( @_ ){if ( m/^--FromPackage/ ) {$from_package = 1;} elsif ( m/^--LinkFile/ ) {$isa_linkfile = 1;} elsif ( m/^--SoftLink=(.+)/ ) {push @llist, $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 ) ){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( "$DebianWorkDir$dst_dir", 0, 0775);unlink ("$DebianWorkDir$dst_file");System ('cp','-f', $src, "$DebianWorkDir$dst_file" );foreach my $lname ( @llist ){$lname = $dst_dir . '/' . $lname unless ( $lname =~ m ~^/~ );MakeSymLink( $dst_file ,$lname);}}}}#-------------------------------------------------------------------------------# 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 - Souve via package roots## Returns :#sub CopyDir{my ($src_dir, $dst_dir, @opts) = @_;my $opt_merge;my $opt_base;my $from_interface = 0;$dst_dir = $DebianWorkDir . '/' . $dst_dir;$dst_dir =~ s~//~/~;## Detect and expand Symbolic names in the Source Directory#foreach ( @opts ){if ( m/^--Merge/ ) {$opt_merge = 1;} elsif ( m/^--Source=(.+)/ ) {my $name = $1;Verbose2 ("CopyDir: Source: $name");Error ("Source directory can only be specified once")if ( defined $opt_base );$name = lc($name);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{$name} ){$opt_base = $CopyDirSymbolic{$name};## If sourceing from interface, then follow# symlinks in the copy. All files will be links anyway#$from_interface = 1if ( $name =~ m~^interface~ );}else{DebugDumpData ("CopyDirSymbolic", \%CopyDirSymbolic);Error ("CopyDir: Unknown Source Name: $name" );}} elsif ( m/^--FromPackage/ ) {Verbose2 ("CopyDir: FromPackage: $src_dir");Error ("Source directory can only be specified once")if ( defined $opt_base );my @path;foreach my $entry ( getPackageList() ){my $base = $entry->getBase(3);next unless ( defined $base );if ( -d $base . '/' . $src_dir ){push @path, $base;$from_interface = 1if ( $entry->{'TYPE'} eq 'interface' );}}Error ("CopyDir: Cannot find source dir in any package: $src_dir")if ( $#path < 0 );Error ("CopyDir: Requested path found in mutiple packages: $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/~ );} else {Error ("CopyDir: Unknown option: $_" );}}$src_dir = $opt_base . '/' . $src_dir if ( $opt_base );$src_dir =~ s~//~/~g;$src_dir =~ s~/$~~;Verbose ("CopyDir: $src_dir, $dst_dir");Error ("CopyDir: Directory not found: $src_dir") unless ( -d $src_dir );## Setup the copy options#my %copyOpts;$copyOpts{'IgnoreDirs'} = ['.svn'];$copyOpts{'EmptyDirs'} = 1;$copyOpts{'DeleteFirst'} = 1 unless $opt_merge;$copyOpts{'Log'} = 1 if ( $opt_verbose > 1 );$copyOpts{'DuplicateLinks'} = 1 unless ( $from_interface );## Transfer the directory#JatsCopy::CopyDir ( $src_dir, $dst_dir, \%copyOpts );## Expand link files that may have been copied in#Verbose ("Locate LINKFILES in $DebianWorkDir");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## Returns :#sub AddInitScript{my $no_copy;my $basedir = "";my @args;my $from_package = 0;## Process and Remove options#foreach ( @_ ){if ( m/^--NoCopy/ ) {$no_copy = 1;} elsif ( m/^--Afc/ ) {$basedir = "/afc";} elsif ( m/^--FromPackage/ ) {$from_package = 1;} 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'));$script = ResolveFile($from_package, $script );my $tdir = $basedir . "/etc/init.d/init.d";my $base = StripDir($script);CopyFile( $script, $tdir ) unless $no_copy;my $link;if ( $start ){$link = sprintf ("${basedir}/etc/init.d/S%2.2d%s", $start, $base );MakeSymLink( "$tdir/$base", $link);}if ( $stop ){$link = sprintf ("${basedir}/etc/init.d/K%2.2d%s", $stop, $base );MakeSymLink( "$tdir/$base", $link);}}#-------------------------------------------------------------------------------# 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) = @_;$dst = $DebianWorkDir . '/' . $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) = @_;Verbose ("EchoFile: $file");$file = $DebianWorkDir . '/' . $file;$file =~ s~//~/~;unlink $file;open (DT, ">", $file ) || Error ("Cannot create $file");print DT $text || Error ("Cannot print to $file");close DT;}#-------------------------------------------------------------------------------# Function : SetFilePerms## Description : Set file permissions on one or more files or directories## Inputs : $perm - Perm Mask# @paths - List of paths/files to process# Options# --Recurse - Recurse subdirs## Returns :#sub SetFilePerms{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 = $DebianWorkDir . '/' . $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");}}}#-------------------------------------------------------------------------------# Function : CreateDir## Description : Create a directory within the target workspace## Inputs : $path - Name of the target directory## Returns : Nothing#sub CreateDir{my ($path) = @_;Verbose ("Create Dir: $path");mkpath( $DebianWorkDir . '/' . $path );}#-------------------------------------------------------------------------------# Function : IsProduct# IsPlatform# IsTarget# IsVariant## 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;}#-------------------------------------------------------------------------------# 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#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 : ExpandLinkFiles## Description : Look for .LINK files in the output image and expand# the links into softlinks## Inputs : None# The rouine works on the $DebianWorkDir directory tree## Returns : Nothing# Will remove .LINKS files that are processed#sub ExpandLinkFiles{foreach my $linkfile ( FindFiles( $DebianWorkDir, ".LINKS" )){next if ( $linkfile =~ m~/\.svn/~ );my $BASEDIR = StripFileExt( $linkfile );$BASEDIR =~ s~^$DebianWorkDir/~~;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;}}#-------------------------------------------------------------------------------# 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## Returns : Path#sub ResolveFile{my ($from_package, $file) = @_;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# This is provided within the build information#my @parts = getPlatformParts ();push @parts, '';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 )}}}Error ("ResolveFile: File not found: $file", "Search Path:", @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## Inputs : $from_package - 0 - Local File# $file## Returns : Path#sub ResolveBinFile{my ($from_package, $file) = @_;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# This is provided within the build information#my @parts = getPlatformParts ();push @parts, '';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 ) ){next if ( m~\.dbg$~ );push @done, $_;}}else{push @done, $sfile if ( -f $sfile || -l $sfile )}}}}Error ("ResolveBinFile: File not found: $file", "Search Path:", @path)unless ( @done );Warning ("ResolveBinFile: Multiple instances of file found. Only first is used", @done)if ( $#done > 0 && ! $wildcard && !wantarray );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## Returns : Path#sub ResolveLibFile{my ($from_package, $file) = @_;my $wildcard = ($file =~ /[*?]/);my @options;my $num_dll;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;} 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# This is provided within the build information#my @parts = getPlatformParts ();push @parts, '';my @done;foreach my $root ( @path ){foreach my $type ( $opt_type, '' ){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;} else {$sfile = "lib" . $file . $type . '.so.*';}$sfile = "$root/$subdir/$sfile";$sfile =~ s~//~/~g;Verbose2("LocateLibFile: $sfile");if ( $exact ){push @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 files.#my %sieve;foreach ( glob ( $sfile ) ){next if ( m~\.dbg$~ );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;}}}}Error ("ResolveLibFile: File not found: $file", "Search Path:", @path)unless ( @done );Warning ("ResolveLibFile: Multiple instances of file found. Only first is used", @done)if ( $#done > 0 && ! $wildcard && !wantarray );return wantarray ? @done : $done[0];}#-------------------------------------------------------------------------------# Function : AUTOLOAD## Description : Intercept bad 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;Error ("Directive not known or not allowed in this context: $fname","Directive: $fname( @_ );","File: $filename, Line: $line" );}1;