######################################################################## # 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; # Workspace my $DebianWorkDir; # Dir to create file system image within # # Command line options # my $opt_debug = $ENV{'GBE_DEBUG'}; # Allow global debug my $opt_verbose = $ENV{'GBE_VERBOSE'}; # Allow global verbose my $opt_vargs; # Verbose arg my $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 List my @ResolveBinFileList; # Cached PackageBin File List my @ResolveLibFileList; # Cached PackageLib File List my %DebianControlFiles; # Control Files my %DebianControlFileNames; # Control Files by name my @DependencyList; # Package Dependencies my @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 file if ( @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 line my $depData = join (', ', @DependencyList ); open (SF, '<', $src) || Error ("UpdateControlFile: Cannot open:$src, $!"); open (DF, '>', $dst) || Error ("UpdateControlFile: Cannot create:$dst, $!"); while ( ) { 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 options foreach ( @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 = 1 if ( $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 = 1 if ( $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 = 1 if ( $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 ( ) { 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" ) or Error("Failed to open file [$ifileLoc] : $!"); open ($tfile, "> $tfileLoc" ) or Error("Failed to open file [$tfileLoc] : $!"); binmode $tfile; while ( <$ifile> ) { s~[\n\r]+$~~; # Chomp print $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" ) or Error("Failed to open file [$ifileLoc] : $!"); open ($tfile, "> $tfileLoc" ) or Error("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 skip if ( -d $fullPath && !defined($dirPerms) ) { Verbose2("SetPermissions: Skipping dir $fullPath as we have no dir permissions"); next; } # A file and we dont have fileperms, so skip if ( -f $fullPath && !defined($filePerms) ) { 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 recursing if ( -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 ( ) { 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;