Rev 4695 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### Copyright (C) 1998-2013 Vix Technology, 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# 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# 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# CreateDir - Create a directory# DebianFiles - Specify control and script files# DebianControlFile - Specify control and script files# DebianDepends - Add Depends entry to control file# 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## 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 JatsSystem;use FileUtils;use JatsError;use JatsLocateFiles;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;my $opt_pkgarch;## Options derived from script directives#my $opt_description;## Globals#my @ResolveFileList; # Cached Package File Listmy @ResolveBinFileList; # Cached PackageBin File Listmy @ResolveLibFileList; # Cached PackageLib File Listmy %DebianControlFiles; # Control Filesmy %DebianControlFileNames; # Control Files by namemy @DependencyList; # Package Dependenciesmy @ConfigList; # Config Files#-------------------------------------------------------------------------------# 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"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,"PkgArch:s" => \$opt_pkgarch,);$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 ("Debian Package Name not set") unless ( $opt_name );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 );## 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";Message " Pkg Arch: $opt_pkgarch" if ($opt_pkgarch);Verbose " Verbose: $opt_verbose";Verbose " InterfaceDir: $opt_interfacedir";Message " Package: $DebianPkgName";Message "======================================================================";## Defaults#$opt_pkgarch = $opt_platform unless ( $opt_pkgarch );## 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#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;}## 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 ( exists($DebianControlFiles{'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" );## Copy in all the named Debian Control files# Ignore any control file. It will be done next#foreach my $key ( keys %DebianControlFiles ){next if ($key eq 'control');CopyFile ( $DebianControlFiles{$key}, '/DEBIAN', $key );}## Create 'conffiles'# Append to any user provided fileif ( @ConfigList ){my $conffiles = "$DebianWorkDir/DEBIAN/conffiles";Warning("Appending user specified entries to conffiles") if ( -f $conffiles);FileAppend( $conffiles, @ConfigList );}## Massage the 'control' file#UpdateControlFile ($DebianControlFiles{'control'} );## Mark all files in the debian folder as read-execute#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 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 UpdateControlFile{my($src) = @_;my $dst = "$DebianWorkDir/DEBIAN/control";unless ( $src ){CreateControlFile();return;}## User has provided a control file# Tweak the internals#Verbose ("UpdateControlFile: $dst" );$src = ResolveFile( 0, $src );# Calc depends linemy $depData = join (', ', @DependencyList );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_name";} elsif ( m~^Version:~ ) {$_ = "Version: $opt_buildversion";} 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 : CreateControlFile## Description : Craete a basic debian control file## Inputs : Uses global variables## Returns :#sub CreateControlFile{my $dst = "$DebianWorkDir/DEBIAN/control";Verbose ("CreateControlFile: $dst" );my $depData = join (', ', @DependencyList );open (DF, '>', $dst) || Error ("CreateControlFile: Cannot create:$dst");print DF "Package: $opt_name\n";print DF "Version: $opt_buildversion\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 : 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{## Extract names#Verbose ("Specify Debian Control Files and Scripts");foreach ( @_ ){if ( m/^--Control=(.+)/i ) {DebianControlFile('control',$1)} elsif ( m/^--PreRm=(.+)/i ) {DebianControlFile('prerm',$1)} elsif ( m/^--PostRm=(.+)/i ) {DebianControlFile('postrm',$1)} elsif ( m/^--PreInst=(.+)/i ) {DebianControlFile('preinst',$1)} elsif ( m/^--PostInst=(.+)/i ) {DebianControlFile('postinst',$1)} else {Error ("DebianFiles: Unknown option: $_");}}}#-------------------------------------------------------------------------------# Function : DebianControlFile## Description : Add special control files to the Debian Installer# Not useful for embedded installers## More general than DebianFiles()## Inputs : name - Target Name# If the name starts with 'package.' then it will be replaced# with the name of the current package# file - Source File Name# options - Options include# --FromPackage## Returns :#sub DebianControlFile{my ($name, $file, @options) = @_;my $fromPackage = 0;## Process optionsforeach ( @options){if (m~^--FromPackage~) {$fromPackage = 1;}else {ReportError(("DebianControlFile: 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("DebianControlFile: Multiple definitions for '$name' not allowed")if (exists $DebianControlFileNames{$simpleName});my $filePath = ResolveFile($fromPackage, $file);## Add info to data structures#$DebianControlFiles{$name} = $filePath;$DebianControlFileNames{$simpleName} = $name;}#-------------------------------------------------------------------------------# Function : DebianDepends## Description : This directive allows simple dependency information to be# inserted into the control file## Not useful in embedded system## Inputs : Entry - A dependency entry# ... - More entries### Returns : Nothing#sub DebianDepends{push @DependencyList, @_;}#-------------------------------------------------------------------------------# 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# --IncludeDebug### 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# --ConfigFile# --IncludeDebug## Returns :#sub CopyFileCommon{my $from_package = 0;my $isa_linkfile = 0;my $isa_configFile = 0;my $include_debug = 0;my @llist;my @args;## Parse options#foreach ( @_ ){if ( m/^--FromPackage/ ) {$from_package = 1;} elsif ( m/^--LinkFile/ ) {$isa_linkfile = 1;} elsif ( m/^--ConfFile/i ) {$isa_configFile = 1;} elsif ( m/^--IncludeDebug/i ) {$include_debug = 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" );if ( $include_debug ){my $dbg_src = "$src.dbg";my $dbg_dst_file = "$dst_file.dbg";if ( -e "$src.dbg" ){Verbose ("CopyFile: Copy debug symbols $dbg_src, $dbg_dst_file" );unlink ("$DebianWorkDir$dbg_dst_file");System ('cp','-f', $dbg_src, "$DebianWorkDir$dbg_dst_file" );}else{Error ("Unable to load debug file $dbg_src" );}}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, $dst_file;}}}#-------------------------------------------------------------------------------# 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# --NoIgnoreDbgFiles - Do not ignore .dbg and .debug files in dir copy# --IfPresent - Not an error if the path cannot be found## Returns :#sub CopyDir{my ($src_dir, $dst_dir, @opts) = @_;my $opt_merge;my $opt_base;my $from_interface = 0;my $ignoreDbg = 1;my $ignoreNoDir;my $user_src_dir = $src_dir;my $opt_source;my $opt_package;$dst_dir = $DebianWorkDir . '/' . $dst_dir;$dst_dir =~ s~//~/~;## Scan and collect user options#foreach ( @opts ){Verbose2 ("CopyDir: $_");if ( m/^--Merge/ ) {$opt_merge = 1;} 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;} elsif ( m/^--NoIgnoreDbgFiles/ ) {$ignoreDbg = 0;} elsif ( m/^--IfPresent/ ) {$ignoreNoDir = 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() ){my $base = $entry->getBase(3);next unless ( defined $base );if ( -d $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 directoru, 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;}## Setup the copy options#my %copyOpts;$copyOpts{'IgnoreDirs'} = ['.svn', '.git', '.cvs', '.hg'];$copyOpts{'Ignore'} = ['.gbedir', '_gbedir'];push (@{$copyOpts{'Ignore'}}, '*.debug', '*.dbg') if $ignoreDbg;$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;# 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";} 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 : 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;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($DebianWorkDir, $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{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($DebianWorkDir, $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 );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## 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 : 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{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 = $DebianWorkDir . '/' . $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## 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;}#************ 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 : 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;}}#************ 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## Returns : Path##************ INTERNAL USE ONLY **********************************************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 ) ){# 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 )}}}}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# --3rdParty - Use exact name provided## 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;} 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# 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;} 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 ){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 (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;}}}}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;