######################################################################## # COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED. # # Module name : JatsSignatureBuilder.pm # Module type : JATS Utility # Compiler(s) : Perl # Environment(s): jats # # Description : Generate a PAckage signature # # #......................................................................# require 5.008_002; use strict; use warnings; package JatsSignatureBuilder; use JatsError; use FileUtils; use JatsVersionUtils; use JatsEnv; use JatsSystem; use ArrayHashUtils; use BuildName; use Digest::SHA::PurePerl qw(sha1); use IPC::Open3; use File::Path; #------------------------------------------------------------------------------- # Function : GeneratePackageSignature # # Description : Generate a package 'signature' for this package # # The signature is used to bypass the entire Make processing in a sandbox # If we can find a matching package in the package store then we don't # need to 'make' this package. # # There are two scenarios: # In a GIT enabled sandbox # Without GIT # # In a GIT enabled sandbox the signature allows the use of a pre-built # package - even if the package has been built on a different branch. # # The signature includes: # The name of this package # The GIT sha1 of the directory trees that contain this package # The package signatures of all dependent packages # # In a Non-GIT enabled sandbox the package signature will be set such that # the package will never be found in the package store and the package MUST # be built within the sandbox. # # The hard part is determing the directory trees that contains this package # Ideally this is a single dir-tree, but this cannot be enforced. # # Source directories have been gathered during makefile generation # # This suits most cases, but there are a few where the user needs # to give JATS a hint. Use the AsdSrcDir directive to extend # the signature paths to directories not under the build.pl # or any makefile included by the build.pl # # The generated file will be held in the sandbox directory. # # Inputs : $pkgBase - Path to the package's build file # $outPath - Base of path to create signature files # # Returns : The package signature # sub GeneratePackageSignature { my ($pkgBase, $outPath) = @_; my %sigExcludeDirs; my %sigExcludeFiles; my $BuildSignatureSha1; my $BuildSignature; my @sigList; my $sigText; Error ("No directory specified") unless $pkgBase; Debug("Build Directory: $pkgBase"); Error ("Not a directory: $pkgBase") unless -d $pkgBase; my $parsedInfo = JatsParser::processBuild ($pkgBase); #DebugDumpData("GeneratePackageSignature::parsedInfo", $parsedInfo); Error ('BuildName not found') unless exists $parsedInfo->{BuildName}; # # Determine the saved locations for the output files # mkpath ( $outPath ) unless -d $outPath; my $signatureFile = CatPaths($outPath, 'Package.sig'); my $sigDebugFile = CatPaths($outPath, 'Package.dsig'); # # Determine if this is a GIT enabled sandbox build # Need a .git directory or file in the root of the sandbox # my $gitEnabled; if ($::GBE_SANDBOX && -e CatPaths ($::GBE_SANDBOX, '.git') ) { $gitEnabled = 1; } # # Start generating the signature # Include the package Name, Version and Project # $BuildSignatureSha1 = Digest::SHA::PurePerl->new; $sigText = "PKGNAME: " . join (' ', @{$parsedInfo->{BuildName}} ); $BuildSignatureSha1->add( $sigText ); push @sigList, $sigText . ": " . $BuildSignatureSha1->clone->hexdigest; # # Include the signature of ALL dependent packages # Ie: The package signature is a function of the source and its dependents # Assume that we are starting with a sorted list # foreach my $tag ( @{$parsedInfo->{PkgList}} ) { my ($pname, $pversion) = split ($;, $tag); my $pkgSig = getPackageSignature($pname, $pversion); $BuildSignatureSha1->add("PKGSIGNATURE: $pkgSig"); push @sigList, sprintf("PKGSIGNATURE: [%s %s] %s: %s", $pname, $pversion, $pkgSig , $BuildSignatureSha1->clone->hexdigest); } if ($gitEnabled) { # # Include the sha1 of all 'git' tree items that form the complete source image # Warn user if not all components are version controlled # my @relDirList = @{$parsedInfo->{DirList}}; my @cmdList = map { 'HEAD:' . $_ . '/' } @relDirList; Debug3(" GIT CMD: " . "git rev-parse", @cmdList ); #DebugDumpData("parsedInfo",$parsedInfo); # # Generate a 'nice' array of display paths used # The display path will be used simply to report the location in the debug of the package signature # The display path is relative to the base of the sandbox # my @absDirList = map { RelPath(FullPath( $_ ),$::GBE_SANDBOX) } @relDirList; # # Callback function to process the output of the Git parse # Expect one line for each HEAD: item # my $index = 0; my @notControlled; my $callback = sub { my ($cdata, $gitShar) = @_; $gitShar =~ s~\s+$~~; Debug3(" GIT OUT: " . $gitShar ); if ($gitShar =~ m~^HEAD:(.*)~) { push @notControlled, $1; $gitShar = 'MSG: Not version controlled'; } $BuildSignatureSha1->add($gitShar); push @sigList, "PKGSRC: $absDirList[$index++]: $gitShar: " . $BuildSignatureSha1->clone->hexdigest; return 0; }; my $rv = GitCmd('rev-parse', @cmdList, { process => $callback } ); Debug2("GitCmd Result: $rv"); $BuildSignature = $BuildSignatureSha1->hexdigest; if (@notControlled) { Warning('The following paths are not version controlled:', @notControlled); } } else { $BuildSignature = 'MSG: Sandbox is not git enabled'; } Message("Signature: $BuildSignature"); push @sigList, "Signature: $BuildSignature"; FileCreate( $signatureFile, $BuildSignature ); FileCreate( $sigDebugFile, @sigList ); Debug0("sigDebugFile: $sigDebugFile"); return $BuildSignature; } #------------------------------------------------------------------------------- # Function : getPackageSignature # # Description : Helper routine # Given a package name and package version determine the package # signature. # # Can used predetermined data or perform a package repo scan # # This version assumes that we are buildign within a jats sandbox # Each packages signature file Package.sig is stored in the packages # interface directory (at the moment). # # Process: # Locate the packages interface directory - we have a link file to it # Read in the PAckage Signature file # # Inputs : $pname - Package Name # $pversion - Package Version # $mode - Optional. true -> do not error if not found # # Returns : The package signature. Undefined if the package canot be found # sub getPackageSignature { my ($pname, $pversion, $mode ) = @_; my $prj = ''; my $pkg; my $version; my $pkgSig; # # We are in a sandbox and expect to find a interface/Package.sig file # This will allow us to locate the package in the package store # # If there is no interface/Package.sig, then the user must build (not make) # the package in the sandbox. # # ie: the interface/Package.sig file allows us to use the package from package cache # or indicates that the user has not yet built the package # # First locate the packages interface directory # We have a nice link from the sandbox to assist in this # my ($pn, $pv, $ps ) = SplitPackage ($pname, $pversion ); $version = 'sandbox'; $prj = '.' . $ps if ( $ps ); $version .= $prj; my $ifaceDir = CatPaths($::GBE_SANDBOX, 'sandbox_dpkg_archive', $pname, $version . '.int'); $ifaceDir = TagFileRead($ifaceDir); $ifaceDir =~ s~\\~/~g; $ifaceDir =~ s~GBE_SANDBOX/~$::GBE_SANDBOX/~; my $pkgSigFile = CatPaths( $ifaceDir, 'Package.sig'); if ( -f $pkgSigFile) { #Debug0("$pname, $pversion --> $pkgSigFile"); $pkgSig = TagFileRead($pkgSigFile); Error("Package signature invalid for $pname/$version", "Signature: $pkgSig") if((length($pkgSig) != 40) && $pkgSig !~ m~^MSG:~) ; } else { Error("Package signature not found for $pname/$version", "You must 'build' the package before using it") unless $mode; } return $pkgSig; } #------------------------------------------------------------------------------- # Function : GitCmd # # Description : Run a Git Command and capture/process the output # # Based on JatsSvnCore:SvnCmd # # Inputs : Command # Command arguments # Last argument may be a hash of options. # nosavedata - Don't save the data # process - Callback function # printdata - Print data # error - Error Message # Used as first line of an Error call # # Returns : non-zero on errors detected # sub GitCmd { my $self; # Local storage Debug ("GitCmd"); # # Locate essential tools # our $GBE_SVN_PATH; EnvImportOptional('GBE_GIT_PATH', ''); Debug ("GBE_GIT_PATH", $::GBE_GIT_PATH); my $stdmux = LocateProgInPath ( 'stdmux'); my $git = LocateProgInPath ( 'git', '--All', '--Path=' . $::GBE_GIT_PATH ); # # Extract arguments and options # If last argument is a hash, then its a hash of options # my $opt; $opt = pop @_ if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')); $self->{PRINTDATA} = $opt->{'printdata'} if ( exists $opt->{'printdata'} ); Verbose2 "GitCmd $git @_"; # # Useful debugging # # $self->{LAST_CMD} = [$svn, @_]; # # Reset command output data # $self->{ERROR_LIST} = []; $self->{RESULT_LIST} = []; # $self->{LAST_CMD} = \@_; # # Make use of a wrapper program to mux the STDERR and STDOUT into # one stream (STDOUT). # This solves a lot of problems # # Do not use IO redirection of STDERR because as this will cause a # shell (sh or cmd.exe) to be invoked and this makes it much # harder to kill on all platforms. # # Use open3 as it allows the arguments to be passed # directly without escaping and without any shell in the way # local (*CHLD_OUT, *CHLD_IN); my $pid = open3( \*CHLD_IN, \*CHLD_OUT, '>&STDERR', $stdmux, $git, @_); # # Looks as though we always get a PID - even if the process dies # straight away or can't be found. I suspect that open3 doesn't set # $! anyway. I know it doesn't set $? # Debug ("Pid: $pid"); Error ("Can't run command: $!") unless $pid; # # Close the input handle # We don't have anything to send to this program # close(CHLD_IN); # # Monitor the output from the utility # Have used stdmux to multiplex stdout and stderr # # Note: IO::Select doesn't work on Windows :( # Note: Open3 will cause blocking unless both streams are read # Can't read both streams because IO::Select doesn't work # # Observation: # svn puts errors to STDERR # svn puts status to STDOUT # while () { s~\s+$~~; tr~\\/~/~; Verbose3 ( "GitCmd:" . $_); m~^STD(...):(.+)~; my $data = $1 ? $2 : $_; next unless ( $data ); if ( $1 && $1 eq 'ERR' ) { # # Process STDERR output # push @{$self->{ERROR_LIST}}, $data; } else { # # Process STDOUT data # push @{$self->{RESULT_LIST}}, $data unless ($opt->{'nosavedata'}); # # If the user has specified a processing function then pass each # line to the specified function. A non-zero return will # be taken as a signal to kill the command. # if ( exists ($opt->{'process'}) && $opt->{'process'}($self, $data) ) { kill 9, $pid; sleep(1); last; } } } close(CHLD_OUT); # # MUST wait for the process # Under Windows if this is not done then we eventually fill up some # perl-internal structure and can't spawn anymore processes. # my $rv = waitpid ( $pid, 0); # # If an error condition was detected and the user has provided # an error message, then display the error # # This simplifies the user error processing # if ( @{$self->{ERROR_LIST}} && $opt->{'error'} ) { Error ( $opt->{'error'}, @{$self->{ERROR_LIST}} ); } # # Exit status has no meaning since open3 has been used # This is because perl does not treat the opened process as a child # Not too sure it makes any difference anyway # # Debug ("Useless Exit Status: $rv"); my $result = @{$self->{ERROR_LIST}} ? 1 : 0; Verbose3 ("Exit Code: $result"); return $result; } ############################################################################### # Internal Package # Primarily to hide the use of the AUTOLOAD # Which still doesn't behave as expected # Have trouble with $self in AUTOLOAD. Its not appearig as an argument. # package JatsParser; use strict; use warnings; my $currentClass; our $ProjectBase; our $ScmRoot; #------------------------------------------------------------------------------- # Function : JatsParser::processBuild # # Description : Process the build.pl file and associated makefile.pl's # A static-ish method to do all of the hard work. # # Inputs : $buildPath - Path to the build file # # Returns : A few globals # sub processBuild { my ($baseDir) = @_; my @AllSubDirs; # # Process the build.pl file # my $filename = ::CatPaths($baseDir, 'build.pl'); ::Error ("Build file not found : $filename") unless -f $filename; $baseDir = ::RelPath(::FullPath ($baseDir)); my $buildParser = newJatsParser(); $buildParser->parseFile($baseDir , 'build.pl'); #DebugDumpData("parser", $parser); # # If no source subdirs where specified in the build file then insert the default one # This is the same action as perform by jats build # if ( ! defined $buildParser->{SubDirs}) { push @{$buildParser->{SubDirs}}, ::CatPaths($baseDir, 'src'); } # # If the 'common' makefile exists then parse it as well # my $commonMakefile = ::CatPaths($baseDir, 'makefile.pl'); unless ( -f $commonMakefile) { $commonMakefile = undef; } # # Add the build path to the list of known subdirectories # @AllSubDirs = $baseDir; # # Process all subdirs # Order is not important - in this case # my @SubDirs = @{$buildParser->{SubDirs}}; my $parser = newJatsParser($baseDir, $commonMakefile); while (@SubDirs) { my $makeDir = ::CleanDirName(pop @SubDirs); @{$parser->{SubDirs}} = (); $parser->parseFile($makeDir, 'makefile.pl'); push @SubDirs, @{$parser->{SubDirs}} if (defined $parser->{SubDirs}); ::UniquePush (\@AllSubDirs, $makeDir); } my @AllInclude = @{$parser->{Includes}} if defined $parser->{Includes}; # # Generate a list of root directories used by the package # ie: want top level directories only and not subdirectories # my @PackageDirs = generateMinDirList(@AllSubDirs, @AllInclude); # # Generate a list of all the external packages # Don't sort the list. Order may be important # my @AllPackages = (); push @AllPackages, @{$buildParser->{PkgList}} if (defined $buildParser->{PkgList}); # # Prepare a structure to be returned # my $data; $data->{BuildName} = $buildParser->{BuildName}; $data->{BaseDir} = $baseDir; $data->{PkgList} = \@AllPackages; $data->{DirList} = \@PackageDirs; return $data; } #------------------------------------------------------------------------------- # Function : generateMinDirList # # Description : Generate a list of root directories used by the package # ie: want top level directories onyl and not subdirectories # # # Inputs : A list of paths to process # # Returns : A list of processed paths # sub generateMinDirList { # # Convert all to absolute paths # my @baseList; foreach (@_) { push @baseList, ::FullPath($_); } # Process the complete list to remove subdirectories # Process is: # Sort list. Will end up with shortest directories first, thus subdirs will follow parents # Insert each item into a new list iff it is not a subdir of something already in the list # my @dirList = sort {uc($a) cmp uc($b)} @baseList; my @newlist; foreach my $newItem ( @dirList ) { my $match = 0; foreach my $item ( @newlist ) { if (index ($newItem, $item) == 0) { $match = 1; last; } } push @newlist, $newItem if (! $match); } # # Convert back to relative paths # @baseList = (); foreach ( @newlist ) { push @baseList, ::RelPath($_); } return @baseList; } #------------------------------------------------------------------------------- # Function : AUTOLOAD # # Description : Intercept and process user directives # It does not attempt to distinguish between user errors and # programming errors. It assumes that the program has been # tested. # # Inputs : Original function arguments (captured) # # our $AUTOLOAD; sub AUTOLOAD { # # Don't respond to class destruction # return if our $AUTOLOAD =~ /::DESTROY$/; my $self = $currentClass; my $type = ref ($self) || ::Error("$self is not an object"); my $args = ::JatsError::ArgsToString( \@_); my $fname = $AUTOLOAD; $fname =~ s~^\w+::~~; my ($package, $filename, $line) = caller; # # If directive is inlined # Replace it with the raw text of the directive # Really only for display purposes # if ($fname eq 'If') { return $fname . '(' . join( ',', map { qq/"$_"/ } @_ ) . ')' ; } # # Capture and process some directives # my %directives = ( AddIncDir => 1, AddSrcDir => 1, AddDir => 1, AddLibDir => 1, LinkPkgArchive => 2, BuildPkgArchive => 2, BuildName => 3, SetProjectBase => 4, SubDir => 5, BuildSubDir => 5, ); if ($directives{$fname}) { # ::Debug0 ("Directive: $fname( $args );", "File: $filename, Line: $line, Mode: $directives{$fname}" ); # AddIncDir # AddSrcDir # AddLibDir # AddDir # Directives that specify directories that extend paths # if ($directives{$fname} == 1) { for (my $ii = 1; $ii < scalar @_; $ii++) { my $arg = $_[$ii]; next if ( $arg =~ m~^--~); #::Debug0("Processing: $arg"); #::DebugDumpData("Self", $self); # # Skip if the path looks like it conatins keywords # interface and local # if ($arg =~ m~/interface/~ || $arg =~ m~/local/~ ) { $arg = '.' } my $dirtyPath = $arg; $dirtyPath = join( '/', $self->{baseDir}, $arg) unless ($arg =~ m~^/~ || $arg =~ m~^\w:~) ; #::Debug0("DirtyPath: $dirtyPath"); my $path = ::CleanPath($dirtyPath ); #::Debug0("CleanPath: $path"); ::UniquePush (\@{$self->{Includes}}, $path); ::Error ("Included directory does not exist: $path") unless -d $path; } } # # LinkPkgArchive # BuildPkgArchive # Directives that define external packages # if ($directives{$fname} == 2) { push @{$self->{PkgList}}, join($;, @_); } # # BuildName # Directive that specifies the Build Name # Format into name, version, suffix # if ($directives{$fname} == 3) { my $build_info = BuildName::parseBuildName( @_ ); $build_info->{BUILDNAME_PROJECT} = $build_info->{BUILDNAME_PROJECT} ? '.' . $build_info->{BUILDNAME_PROJECT} : ''; my @data = ($build_info->{BUILDNAME_PACKAGE}, $build_info->{BUILDNAME_VERSION}, $build_info->{BUILDNAME_PROJECT}); $self->{BuildName} = \@data; } # # SetProjectBase # Handle ProjectBase variable # Only handle a subset as I want to deprecate this # Handle ONLY one arg # Must be either : --Up=nn, or a string ( ../.. ); # if ($directives{$fname} == 4) { if (scalar @_ > 1 ) { :: Error ("Multiple arguments to SetProjectBase not supported"); } my $dirString = $_[0]; if ($dirString =~ m~--Up=(\d+)~) { my $count = $1; $dirString = '/..' x $count; } my $newProjectBase = $self->{ProjectBase} . $dirString; $newProjectBase = ::CleanPath($newProjectBase); #::Debug0 ("SetProjectBase:" . $newProjectBase); no strict; no warnings 'all'; $ProjectBase = $newProjectBase; #::Debug0 ("ProjectBase: $ProjectBase"); } # # SubDir # BuildSubDir # Directives that specify subdirectories to be included in the build # Assume they are relative # if ($directives{$fname} == 5) { foreach ( @_ ) { push @{$self->{SubDirs}}, ::CatPaths($self->{baseDir}, $_ ); } } } } #------------------------------------------------------------------------------- # Function : newJatsParser # # Description : New instance of a JatsParser object # # Inputs : $buildBase - Root of the build # $commonFile - Common makefile to be prefixed to all # # Returns : # sub newJatsParser { my ($buildBase, $commonFile) = @_; my $class = 'JatsParser'; my $self = {}; bless $self, $class; # # Init Data # $self->{baseDir} = ''; $self->{filename} = ''; $self->{SubDirs} = (); $self->{PkgList} = (); $self->{Includes} = (); $self->{ScmRoot} = ::FullPath($buildBase) if defined $buildBase ; $self->{ProjectBase} = $self->{ScmRoot}; $self->{Common} = $commonFile if defined $commonFile; # # Return class # return $self; } #------------------------------------------------------------------------------- # Function : parseFile # # Description : Parse a build or makefile and return data # # Inputs : $baseDir - Base directory # $filename - File to process # # Returns : stuff # sub parseFile { my ($self, $baseDir, $filename) = @_; $currentClass = $self; $self->{baseDir} = $baseDir; $self->{filename} = $filename; $filename = ::CatPaths($baseDir,$filename); ::Error("parseFile. File not found: $filename") unless -f $filename; # # Set Jats-global variables # $ProjectBase # $ScmRoot # no strict; $ProjectBase = $self->{ProjectBase}; $ScmRoot = ::RelPath( $self->{ScmRoot}, ::FullPath($self->{baseDir}) ) if defined( $self->{ScmRoot}); local @ARGV; $ARGV[1] = 'Dummy'; use strict; # # Create the code to be processed # Join the common-makefile and the user-makefile # Set Line numbers and filenames # my $commonCode = "#No Common Code\n"; $commonCode = slurpFile($self,$self->{Common}) if (exists $self->{Common}); my $code = slurpFile($self,$filename); # ::Debug0("code:\n", $commonCode . $code); # # Evaluate the code # no strict; no warnings 'all'; eval $commonCode . $code; if ($@) { ::Error('Bad eval of Code:', $@); ::Debug0("Code", $code); } use strict; use warnings; # ::DebugDumpData("ParsedData", $self); } #------------------------------------------------------------------------------- # Function : slurpFile # # Description : Read and entire (build / makefile ) into a string # Clean it up a little bit # # Inputs : $file - File to process # # Returns : Entire file as a sinngle string # sub slurpFile { my ($self, $file) = @_; local $/; open my $fh, '<', $file or ::Error("Cannot open $file. $!" ); $/ = undef; my $data = <$fh>; close $fh; # # Remove ugly directives # Messes with line numbers # $data =~ s~^\s*require.*~_JatsRequire();~gm; $data =~ s~^\s*die.*~_JatsDie();~mg; $data =~ s~^\s*unless.*~_JatsUnless();~mg; $data =~ s~^\s*\$MAKELIB_PL\s+.*~_JatsDefine();~mg; $data =~ s~^\s*\$BUILDLIB_PL\s+.*~_JatsDefine();~mg; # # Some old build files use some rubbish perl # # $data =~ s~^my~#my~mg; # # Put a nice header on the file for error reporting # my $absName = ::FullPath($file); my $header = "#line 1 \"$absName\"\n" ; return $header . $data; } 1;