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