diff --git a/modules/ksb/BuildContext.pm b/modules/ksb/BuildContext.pm index 4e647fc..522e487 100644 --- a/modules/ksb/BuildContext.pm +++ b/modules/ksb/BuildContext.pm @@ -1,1054 +1,1058 @@ package ksb::BuildContext 0.36; # Class: BuildContext # # This contains the information needed about the build context, e.g. list of # modules, what phases each module is in, the various options, etc. use 5.014; use warnings; no if $] >= 5.018, 'warnings', 'experimental::smartmatch'; use Carp 'confess'; use File::Basename; # dirname use IO::File; use POSIX qw(strftime); use Errno qw(:POSIX); use Mojo::JSON qw(encode_json decode_json); # We derive from ksb::Module so that BuildContext acts like the 'global' # ksb::Module, with some extra functionality. # TODO: Derive from OptionsBase directly and remove getOption override use parent qw(ksb::Module); use ksb::BuildException; use ksb::Debug; use ksb::Util; use ksb::PhaseList; use ksb::Module; use ksb::Module::BranchGroupResolver; use ksb::Updater::KDEProjectMetadata 0.20; use ksb::Version qw(scriptVersion); use ksb::StatusView 0.30; use ksb::StatusMonitor; use ksb::KDEProjectsReader 0.50; use File::Temp qw(tempfile); use File::Spec; # rel2abs +use List::Util qw(sum); + my @DefaultPhases = qw/update build install/; my @rcfiles = ("./kdesrc-buildrc", "$ENV{HOME}/.kdesrc-buildrc"); my $LOCKFILE_NAME = '.kdesrc-lock'; # The # will be replaced by the directory the rc File is stored in. my $PERSISTENT_FILE_NAME = '#/.kdesrc-build-data'; my $SCRIPT_VERSION = scriptVersion(); # Should be used for internal state that shouldn't be exposed as a hidden # cmdline option, or has other cmdline switches (e.g. debug/verbose handling). my %internalGlobalOptions = ( "async" => 1, "build-system-only" => "", "build-when-unchanged" => 1, # Safe default "colorful-output" => 1, # Use color by default. "debug-level" => ksb::Debug::INFO, "filter-out-phases" => '', "git-desired-protocol" => 'https', # protocol to grab from kde-projects "git-repository-base" => {}, # Base path template for use multiple times. "ignore-modules" => '', # See also: use-modules, kde-projects "include-dependencies" => 0, # Recursively include kde-projects module deps? "manual-build" => "", "manual-update" => "", "niceness" => "10", "no-svn" => "", # TODO: Rename to no-src "prefix" => "", # Override installation prefix. "pretend" => "", "reconfigure" => "", "refresh-build" => "", "repository" => '', # module's git repo "revision" => '', # Only useful for Subversion modules at cmdline "set-env" => { }, # Hash of environment vars to set "ssh-identity-file" => '', # If set, is passed to ssh-add. "use-modules" => "", ); # Holds boolean flags that could be altered from cmdline. # These must be completely disjoint from the options provided in # ksb::Application to GetOptionsFromArray! our %defaultGlobalFlags = ( "delete-my-patches" => 0, # Should only be set from cmdline "delete-my-settings" => 0, # Should only be set from cmdline "disable-agent-check" => 0, # If true we don't check on ssh-agent "disable-snapshots" => 1, # 2016-07-31 Temp. disabled until kde.org fixed to supply snapshots "ignore-kde-structure" => 0, # Whether to use kde dir structure like extragear/network "include-dependencies" => 0, # 2019-08-31 Made negatable from cmdline (NB: false here but true in rcfile) "install-after-build" => 1, "install-environment-driver" => 1, # Setup ~/.config/kde-env-*.sh for login scripts "install-session-driver" => 0, # Above, + ~/.xsession "purge-old-logs" => 1, "run-tests" => 0, # 1 = make test, upload = make Experimental "stop-on-failure" => 0, "use-clean-install" => 0, "use-idle-io-priority" => 0, "use-stable-kde" => 0, ); # Holds other cmdline-accessible options that aren't simply binary flags. our %defaultGlobalOptions = ( "binpath" => '', "branch" => "", "branch-group" => "", # Overrides branch, uses JSON data. "build-dir" => "build", "cmake-options" => "", "configure-flags" => "", "custom-build-command" => '', "cxxflags" => "-pipe", "dest-dir" => '${MODULE}', # single quotes used on purpose! "do-not-compile" => "", "http-proxy" => '', # Proxy server to use for HTTP. "kdedir" => "$ENV{HOME}/kde", "libpath" => "", "log-dir" => "log", "make-install-prefix" => "", # Some people need sudo "make-options" => "", "module-base-path" => "", # Used for tags and branches "override-build-system"=> "", "override-url" => "", "persistent-data-file" => "", "qtdir" => "", "remove-after-install" => "none", # { none, builddir, all } "source-dir" => "$ENV{HOME}/kdesrc", "svn-server" => "svn://anonsvn.kde.org/home/kde", "tag" => "", ); sub new { my ($class, @args) = @_; # It is very important to use the ksb::Module:: syntax instead of ksb::Module->, # otherwise you can't pass $class and have it used as the classname. my $self = ksb::Module::new($class, undef, 'global'); my %newOpts = ( modules => [], context => $self, # Fix link to buildContext (i.e. $self) build_options => { global => { %internalGlobalOptions, %defaultGlobalFlags, %defaultGlobalOptions, }, # Module options are stored under here as well, keyed by module->name() }, # This one replaces ksb::Module::{phases} phases => ksb::PhaseList->new(@DefaultPhases), errors => { # A map from module *names* (as in modules[] above) to the # phase name at which they failed. }, logPaths=> { # Holds a hash table of log path bases as expanded by # getSubdirPath (e.g. [source-dir]/log) to the actual log dir # *this run*, with the date and unique id added. You must still # add the module name to use. }, rcFiles => [@rcfiles], rcFile => undef, env => { }, persistent_options => { }, # These are kept across multiple script runs ignore_list => [ ], # List of KDE project paths to ignore completely kde_projects_metadata => undef, # Enumeration of kde-projects kde_dependencies_metadata => undef, # Dependency resolution of kde-projects logical_module_resolver => undef, # For branch-group option status_monitor => ksb::StatusMonitor->new(), projects_db => undef, # See getProjectDataReader ); # Merge all new options into our self-hash. @{$self}{keys %newOpts} = values %newOpts; $self->{options} = $self->{build_options}{global}; assert_isa($self, 'ksb::Module'); assert_isa($self, 'ksb::BuildContext'); return $self; } # Gets the ksb::PhaseList for this context, and optionally sets it first to # the ksb::PhaseList passed in. sub phases { my ($self, $phases) = @_; if ($phases) { confess("Invalid type, expected PhaseList") unless $phases->isa('ksb::PhaseList'); $self->{phases} = $phases; } return $self->{phases}; } sub addModule { my ($self, $module) = @_; Carp::confess("No module to push") unless $module; my $path; if (list_has($self->{modules}, $module)) { debug("Skipping duplicate module ", $module->name()); } # TODO: Shouldn't this support all modules, not just 'proj' modules? elsif ($module->scmType() eq 'proj' && ($path = $module->fullProjectPath()) && # See if the name matches any given in the ignore list. any(sub { $path =~ /(^|\/)$_($|\/)/ }, $self->{ignore_list})) { debug("Skipping ignored module $module"); } else { debug("Adding $module to module list"); push @{$self->{modules}}, $module; } } # Returns a listref of the modules to build sub moduleList { my $self = shift; return $self->{modules}; } # Adds a list of modules to ignore processing on completely. # Parameters should simply be a list of KDE project paths to ignore, # e.g. 'extragear/utils/kdesrc-build'. Partial paths are acceptable, matches # are determined by comparing the path provided to the suffix of the full path # of modules being compared. See KDEProjectsReader::_projectPathMatchesWildcardSearch # # Existing items on the ignore list are not removed. sub addToIgnoreList { my $self = shift; push @{$self->{ignore_list}}, @_; } sub setupOperatingEnvironment { my $self = shift; # Set the process priority POSIX::nice(int $self->getOption('niceness')); # Set the IO priority if available. if ($self->getOption('use-idle-io-priority')) { # -p $$ is our PID, -c3 is idle priority # 0 return value means success if (safe_system('ionice', '-c3', '-p', $$) != 0) { warning (" b[y[*] Unable to lower I/O priority, continuing..."); } } # Get ready for logged output. ksb::Debug::setLogFile($self->getLogDirFor($self) . '/build-log'); # Propagate HTTP proxy through environment unless overridden. if ((my $proxy = $self->getOption('http-proxy')) && !defined $ENV{'http_proxy'}) { $self->queueEnvironmentVariable('http_proxy', $proxy); } } # Clears the list of environment variables to set for log_command runs. sub resetEnvironment { my $self = assert_isa(shift, 'ksb::BuildContext'); $self->{env} = { }; } # Adds an environment variable and value to the list of environment # variables to apply for the next subprocess execution. # # Note that these changes are /not/ reflected in the current environment, # so if you are doing something that requires that kind of update you # should do that yourself (but remember to have some way to restore the old # value if necessary). # # In order to keep compatibility with the old 'setenv' sub, no action is # taken if the value is not equivalent to boolean true. sub queueEnvironmentVariable { my $self = assert_isa(shift, 'ksb::BuildContext'); my ($key, $value) = @_; return unless $value; debug ("\tQueueing g[$key] to be set to y[$value]"); $self->{env}->{$key} = $value; } # Applies all changes queued by queueEnvironmentVariable to the actual # environment irretrievably. Use this before exec()'ing another child, for # instance. sub commitEnvironmentChanges { my $self = assert_isa(shift, 'ksb::BuildContext'); while (my ($key, $value) = each %{$self->{env}}) { $ENV{$key} = $value; debug ("\tSetting environment variable g[$key] to g[b[$value]"); } } # Adds the given library paths to the path already given in an environment # variable. In addition, detected "system paths" are stripped to ensure # that we don't inadvertently re-add a system path to be promoted over the # custom code we're compiling (for instance, when a system Qt is used and # installed to /usr). # # If the environment variable to be modified has already been queued using # queueEnvironmentVariable, then that (queued) value will be modified and # will take effect with the next forked subprocess. # # Otherwise, the current environment variable value will be used, and then # queued. Either way the current environment will be unmodified afterward. # # First parameter is the name of the environment variable to modify # All remaining parameters are prepended to the current environment path, in # the order given. (i.e. param1, param2, param3 -> # param1:param2:param3:existing) sub prependEnvironmentValue { my $self = assert_isa(shift, 'ksb::BuildContext'); my ($envName, @items) = @_; my @curPaths = split(':', $self->{env}->{$envName} // $ENV{$envName} // ''); # Filter out entries to add that are already in the environment from # the system. for my $path (grep { list_has(\@curPaths, $_) } (@items) ) { debug ("\tNot prepending y[$path] to y[$envName] as it appears " . "to already be defined in y[$envName]."); } @items = grep { not list_has(\@curPaths, $_); } (@items); my $envValue = join(':', @items, @curPaths); $envValue =~ s/^:*//; $envValue =~ s/:*$//; # Remove leading/trailing colons $envValue =~ s/:+/:/; # Remove duplicate colons $self->queueEnvironmentVariable($envName, $envValue); } # Tries to take the lock for our current base directory, which currently is # what passes for preventing people from accidentally running kdesrc-build # multiple times at once. The lock is based on the base directory instead # of being global to allow for motivated and/or brave users to properly # configure kdesrc-build to run simultaneously with different # configurations. # # Return value is a boolean success flag. sub takeLock { my $self = assert_isa(shift, 'ksb::BuildContext'); my $baseDir = $self->baseConfigDirectory(); my $lockfile = "$baseDir/$LOCKFILE_NAME"; $! = 0; # Force reset to non-error status sysopen LOCKFILE, $lockfile, O_WRONLY | O_CREAT | O_EXCL; my $errorCode = $!; # Save for later testing. if ($errorCode == EEXIST) { # Path already exists, read the PID and see if it belongs to a # running process. open (my $pidFile, "<", $lockfile) or do { # Lockfile is there but we can't open it?!? Maybe a race # condition but I have to give up somewhere. warning (" WARNING: Can't open or create lockfile r[$lockfile]"); return 1; }; my $pid = <$pidFile>; close $pidFile; if ($pid) { # Recent kdesrc-build; we wrote a PID in there. chomp $pid; # See if something's running with this PID. if (kill(0, $pid) == 1) { # Something *is* running, likely kdesrc-build. Don't use error, # it'll scan for $! print ksb::Debug::colorize(" r[*y[*r[*] kdesrc-build appears to be running. Do you want to:\n"); print ksb::Debug::colorize(" (b[Q])uit, (b[P])roceed anyways?: "); my $choice = // ''; chomp $choice; if (lc $choice ne 'p') { say ksb::Debug::colorize(" y[*] kdesrc-build run canceled."); return 0; } # We still can't grab the lockfile, let's just hope things # work out. note (" y[*] kdesrc-build run in progress by user request."); return 1; } # If we get here, then the program isn't running (or at least not # as the current user), so allow the flow of execution to fall # through below and unlink the lockfile. } # pid # No pid found, optimistically assume the user isn't running # twice. warning (" y[WARNING]: stale kdesrc-build lockfile found, deleting."); unlink $lockfile; sysopen (LOCKFILE, $lockfile, O_WRONLY | O_CREAT | O_EXCL) or do { error (" r[*] Still unable to lock $lockfile, proceeding anyways..."); return 1; }; # Hope the sysopen worked... fall-through } elsif ($errorCode == ENOTTY) { # Stupid bugs... normally sysopen will return ENOTTY, not sure who's to blame between # glibc and Perl but I know that setting PERLIO=:stdio in the environment "fixes" things. ; # pass } elsif ($errorCode != 0) # Some other error occurred. { warning (" r[*]: Error $errorCode while creating lock file (is $baseDir available?)"); warning (" r[*]: Continuing the script for now..."); # Even if we fail it's generally better to allow the script to proceed # without being a jerk about things, especially as more non-CLI-skilled # users start using kdesrc-build to build KDE. return 1; } say LOCKFILE "$$"; close LOCKFILE; return 1; } # Releases the lock obtained by takeLock. sub closeLock { my $self = assert_isa(shift, 'ksb::BuildContext'); my $baseDir = $self->baseConfigDirectory(); my $lockFile = "$baseDir/$LOCKFILE_NAME"; unlink ($lockFile) or warning(" y[*] Failed to close lock: $!"); } # This subroutine accepts a Module parameter, and returns the log directory # for it. You can also pass a BuildContext (including this one) to get the # default log directory. # # As part of setting up what path to use for the log directory, the # 'latest' symlink will also be setup to point to the returned log # directory. sub getLogDirFor { my ($self, $module) = @_; my $baseLogPath = $module->getSubdirPath('log-dir'); my $logDir; if (!exists $self->{logPaths}{$baseLogPath}) { # No log dir made for this base, do so now. my $id = '01'; my $date = strftime "%F", localtime; # ISO 8601 date $id++ while -e "$baseLogPath/$date-$id"; $self->{logPaths}{$baseLogPath} = "$baseLogPath/$date-$id"; } $logDir = $self->{logPaths}{$baseLogPath}; super_mkdir($logDir); # global logs go to basedir directly $logDir .= "/$module" unless $module->isa('ksb::BuildContext'); return $logDir; } # Constructs the appropriate full path to a log file based on the given # basename (including extensions). Use this instead of getLogDirFor when you # actually intend to create a log, as this function will also adjust the # 'latest' symlink properly. sub getLogPathFor { my ($self, $module, $path) = @_; my $baseLogPath = $module->getSubdirPath('log-dir'); my $logDir = $self->getLogDirFor($module); # We create this here to avoid needless empty module directories everywhere super_mkdir($logDir); # Add a symlink to the latest run for this module. 'latest' itself is # a directory under the base log directory that holds symlinks mapping # each module name to the specific log directory most recently used. my $latestPath = "$baseLogPath/latest"; # Handle stuff like playground/utils or KDE/kdelibs my ($moduleName, $modulePath) = fileparse($module->name()); $latestPath .= "/$modulePath" if $module->name() =~ m(/); super_mkdir($latestPath); my $symlink = "$latestPath/$moduleName"; if (-l $symlink and readlink($symlink) ne $logDir) { unlink($symlink); symlink($logDir, $symlink); } elsif(not -e $symlink) { # Create symlink initially if we've never done it before. symlink($logDir, $symlink); } return "$logDir/$path"; } # Returns rc file in use. Call loadRcFile first. sub rcFile { my $self = shift; return $self->{rcFile}; } # Forces the rc file to be read from to be that given by the first # parameter. sub setRcFile { my ($self, $file) = @_; $self->{rcFiles} = [$file]; $self->{rcFile} = undef; } # Returns an open filehandle to the user's chosen rc file. Use setRcFile # to choose a file to load before calling this function, otherwise # loadRcFile will search the default search path. After this function is # called, rcFile() can be used to determine which file was loaded. # # If unable to find or open the rc file an exception is raised. Empty rc # files are supported however. sub loadRcFile { my $self = shift; my @rcFiles = @{$self->{rcFiles}}; my $fh; for my $file (@rcFiles) { if (open ($fh, '<', "$file")) { $self->{rcFile} = File::Spec->rel2abs($file); return $fh; } } # No rc found, check if we can use default. if (scalar @rcFiles == 1) { # This can only happen if the user uses --rc-file, so if we fail to # load the file, we need to fail to load at all. my $failedFile = $rcFiles[0]; error (<rcFile() or croak_internal("Call to baseConfigDirectory before loadRcFile"); return dirname($rcfile); } sub modulesInPhase { my ($self, $phase) = @_; my @list = grep { list_has([$_->phases()->phases()], $phase) } (@{$self->moduleList()}); return @list; } # Searches for a module with a name that matches the provided parameter, # and returns its ksb::Module object. Returns undef if no match was found. # As a special-case, returns the BuildContext itself if the name passed is # 'global', since the BuildContext also is a (in the "is-a" OOP sense) # ksb::Module, specifically the 'global' one. sub lookupModule { my ($self, $moduleName) = @_; return $self if $moduleName eq 'global'; my @options = grep { $_->name() eq $moduleName } (@{$self->moduleList()}); return undef unless @options; if (scalar @options > 1) { croak_internal("Detected 2 or more $moduleName ksb::Module objects"); } return $options[0]; } sub markModulePhaseSucceeded { my ($self, $phase, $module, $extras) = @_; assert_isa($module, 'ksb::Module'); - my $name = $module->name(); $extras //= { }; - $self->{status_monitor}->markPhaseComplete($name, $phase, 'success', %{$extras}); + + $extras->{elapsed} = sum values %{$module->{metrics}->{time_in_phase}}; + + $self->{status_monitor}->markPhaseComplete($module->name(), $phase, 'success', %{$extras}); } sub markModulePhaseFailed { my ($self, $phase, $module) = @_; assert_isa($module, 'ksb::Module'); my $name = $module->name(); my %details; if ((my $log = $module->getOption('#error-log-file', 'module'))) { $details{error_log} = "/error_log/$name"; $details{error_file} = $log; } $self->{status_monitor}->markPhaseComplete($name, $phase, 'error', %details); $self->{errors}->{$name} = $phase; } # Returns a list (i.e. not a reference to, but a real list) of Modules that failed to # complete the given phase. sub failedModulesInPhase { my ($self, $phase) = @_; my @failures = grep { ($self->{errors}->{$_->name()} // '') eq $phase } (@{$self->moduleList()}); return @failures; } # Returns true if the given module had a failure in any phase sub hasModuleFailed { my ($self, $module) = @_; return exists $self->{errors}->{$module->name()}; } # Returns a list of modules that had a failure of some sort, in the order the modules # are listed in our current module list. sub listFailedModules { my $self = shift; my @modules = @{$self->moduleList()}; # grepping for failures instead of returning error list directly maintains ordering @modules = grep { exists $self->{errors}->{$_->name()} } (@modules); return @modules; } # OVERRIDE: Our immediate parent class Module overrides this, but we actually # want the OptionsBase version to be used instead, until we break the recursive # use of Module's own getOption calls on our getOption. sub getOption { &ksb::OptionsBase::getOption; } # OVERRIDE: Overrides OptionsBase::setOption to handle some global-only options. sub setOption { my ($self, %options) = @_; # Special-case handling my $repoOption = 'git-repository-base'; if (exists $options{$repoOption}) { my $value = $options{$repoOption}; my ($repo, $url) = ($value =~ /^([a-zA-Z0-9_-]+)\s+(.+)$/); # This will be a hash reference instead of a scalar $value = $self->getOption($repoOption) || { }; if (!$repo || !$url) { die ksb::BuildException::Config->new($repoOption, "Invalid git-repository-base setting: $value"); } $value->{$repo} = $url; delete $options{$repoOption}; } # Actually set options. $self->SUPER::setOption(%options); # Automatically respond to various global option changes. while (my ($key, $value) = each %options) { my $normalizedKey = $key; $normalizedKey =~ s/^#//; # Remove sticky key modifier. given ($normalizedKey) { when ('colorful-output') { ksb::Debug::setColorfulOutput($value); } when ('debug-level') { ksb::Debug::setDebugLevel($value); } when ('pretend') { ksb::Debug::setPretending($value); } } } } # # Persistent option handling # # Returns the name of the file to use for persistent data. # Supports expanding '#' at the beginning of the filename to the directory # containing the rc-file in use, but only for the default name at this # point. sub persistentOptionFileName { my $self = shift; my $filename = $self->getOption('persistent-data-file'); if (!$filename) { $filename = $PERSISTENT_FILE_NAME; my $dir = $self->baseConfigDirectory(); $filename =~ s/^#/$dir/; } else { # Tilde-expand $filename =~ s/^~\//$ENV{HOME}\//; } return $filename; } # Reads in all persistent options from the file where they are kept # (.kdesrc-build-data) for use in the program. # # The directory used is the same directory that contains the rc file in use. sub loadPersistentOptions { my $self = assert_isa(shift, 'ksb::BuildContext'); my $fh = IO::File->new($self->persistentOptionFileName(), '<'); return unless $fh; # $persistent_data should be a JSON object which we can store directly as a # hash. my $persistent_data; { local $/ = undef; # Read in whole file with <> operator. $persistent_data = <$fh>; } my $persistent_options = decode_json($persistent_data); # We need to keep persistent data with the context instead of with the # applicable modules since otherwise we might forget to write out # persistent data for modules we didn't build in this run. So, we just # store it all. # Layout of this data: # $self->persistent_options = { # 'module-name' => { # option => value, # # foreach option/value pair # }, # # foreach module # } $persistent_options = {} if ref $persistent_options ne 'HASH'; $self->{persistent_options} = $persistent_options; } # Writes out the persistent options to the file .kdesrc-build-data. # # The directory used is the same directory that contains the rc file in use. sub storePersistentOptions { my $self = assert_isa(shift, 'ksb::BuildContext'); return if pretending(); my $fh = IO::File->new($self->persistentOptionFileName(), '>'); if (!$fh) { error ("Unable to save persistent module data: b[r[$!]"); return; } my $encodedJSON = encode_json ($self->{persistent_options}); print $fh $encodedJSON; undef $fh; # Closes the file } # Returns the value of a "persistent" option (normally read in as part of # startup), or undef if there is no value stored. # # First parameter is the module name to get the option for, or 'global' if # not for a module. # Note that unlike setOption/getOption, no inheritance is done at this # point so if an option is present globally but not for a module you # must check both if that's what you want. # Second parameter is the name of the value to retrieve (i.e. the key) sub getPersistentOption { my ($self, $moduleName, $key) = @_; my $persistent_opts = $self->{persistent_options}; # We must check at each level of indirection to avoid # "autovivification" return unless exists $persistent_opts->{$moduleName}; return unless exists $persistent_opts->{$moduleName}{$key}; return $persistent_opts->{$moduleName}{$key}; } # Clears a persistent option if set (for a given module and option-name). # # First parameter is the module name to get the option for, or 'global' for # the global options. # Second parameter is the name of the value to clear. # No return value. sub unsetPersistentOption { my ($self, $moduleName, $key) = @_; my $persistent_opts = $self->{persistent_options}; if (exists $persistent_opts->{$moduleName} && exists $persistent_opts->{$moduleName}->{$key}) { delete $persistent_opts->{$moduleName}->{$key}; } } # Sets a "persistent" option which will be read in for a module when # kdesrc-build starts up and written back out at (normal) program exit. # # First parameter is the module name to set the option for, or 'global'. # Second parameter is the name of the value to set (i.e. key) # Third parameter is the value to store, which must be a scalar. sub setPersistentOption { my ($self, $moduleName, $key, $value) = @_; my $persistent_opts = $self->{persistent_options}; # Initialize empty hash ref if nothing defined for this module. $persistent_opts->{$moduleName} //= { }; $persistent_opts->{$moduleName}{$key} = $value; } # Returns the ksb::Module (which has a 'metadata' scm type) that is used for # kde-build-metadata, so that other modules that need it can call into it if # necessary. # # Also may return undef if the metadata is unavailable or has not yet # been set by setKDEDependenciesMetadataModule (this method does not # automatically create the needed module). sub getKDEDependenciesMetadataModule { my $self = shift; return $self->{kde_dependencies_metadata}; } # Returns the ksb::Module (which has a 'metadata' scm type) that is used for # kde-project metadata, so that other modules that need it can call into it if # necessary. # # Also may return undef if the metadata is unavailable or has not yet # been set by setKDEProjectsMetadataModule (this method does not # automatically create the needed module). sub getKDEProjectsMetadataModule { my $self = shift; return $self->{kde_projects_metadata}; } # Call this method to force this build context to pull in the kde-build-metadata # module. This is a one-time action, subsequent calls to this method # are ignored. Use getKDEDependenciesMetadataModule to see if this build context is # using a metadata module. # # This method should be called before setModuleList. sub setKDEDependenciesMetadataModuleNeeded { my $self = assert_isa(shift, 'ksb::BuildContext'); return if defined $self->{kde_dependencies_metadata}; my $metadata = ksb::ModuleSet::KDEProjects::getDependenciesModule($self); debug ("Introducing dependency metadata into the build"); assert_isa($metadata->scm(), 'ksb::Updater::KDEProjectMetadata'); $self->{kde_dependencies_metadata} = $metadata; return; } # Call this method to force this build context to pull in the # sysadmin/repo-metadata module. This is a one-time action, # subsequent calls to this method are ignored. Use # getKDEProjectsMetadataModule to see if this build context is using # a metadata module. # # This method should be called before setModuleList. sub setKDEProjectsMetadataModuleNeeded { my $self = assert_isa(shift, 'ksb::BuildContext'); return if defined $self->{kde_projects_metadata}; my $metadata = ksb::ModuleSet::KDEProjects::getProjectMetadataModule($self); debug ("Introducing project enumeration metadata into the build"); assert_isa($metadata->scm(), 'ksb::Updater::KDEProjectMetadata'); $self->{kde_projects_metadata} = $metadata; return; } # Returns a KDEProjectsReader module, which has already read in the database and # is ready to be queried. Note that exceptions can be thrown in the process # of downloading and parsing the database information, so be ready for that. sub getProjectDataReader { my $self = shift; return $self->{projects_db} if $self->{projects_db}; my $projectDatabaseModule = $self->getKDEProjectsMetadataModule() or croak_runtime("kde-projects repository information could not be downloaded: $!"); my $protocol = $self->getOption('git-desired-protocol') || 'git'; if (!list_has(['git', 'http', 'https'], $protocol)) { error (" b[y[*] Invalid b[git-desired-protocol] $protocol"); error (" b[y[*] Try setting this option to 'git' if you're not using a proxy"); croak_runtime ("Invalid git-desired-protocol: $protocol"); } $self->{projects_db} = ksb::KDEProjectsReader->new($projectDatabaseModule, $protocol); return $self->{projects_db}; } # Returns the effective branch group to use for modules. You should not call # this unless kde-build-metadata is also in use (see # setKDEDependenciesMetadataModule and moduleBranchGroupResolver). sub effectiveBranchGroup { my $self = shift; my $branchGroup = $self->getOption('branch-group', 'module') // ''; if (!$branchGroup) { $branchGroup = $self->getOption('use-stable-kde') ? 'latest-qt4' : ($self->hasOption('use-stable-kde') # Could also be false if unset ? 'kf5-qt5' # Really set to false : 'latest-qt4'); # Unset / this is default branch group if no option set } return $branchGroup; } # Returns a ksb::Module::BranchGroupResolver which can be used to efficiently # determine a git branch to use for a given kde-projects module (when the # branch-group option is in use), as specified at # https://community.kde.org/Infrastructure/Project_Metadata. sub moduleBranchGroupResolver { my $self = shift; if (!$self->{logical_module_resolver}) { my $metadataModule = $self->getKDEDependenciesMetadataModule(); croak_internal("Tried to use branch-group, but needed data wasn't loaded!") unless $metadataModule; my $resolver = ksb::Module::BranchGroupResolver->new( $metadataModule->scm()->logicalModuleGroups()); $self->{logical_module_resolver} = $resolver; } return $self->{logical_module_resolver}; } # An event-based aggregator for update events, to be used by user interfaces, # including remote interfaces. sub statusMonitor { my $self = shift; return $self->{status_monitor}; } 1; diff --git a/modules/ksb/Module.pm b/modules/ksb/Module.pm index 9190135..6e1def6 100644 --- a/modules/ksb/Module.pm +++ b/modules/ksb/Module.pm @@ -1,1175 +1,1181 @@ package ksb::Module 0.20; # Class: Module # # Represents a source code module of some sort, which can be updated, built, # and installed. Includes a stringifying overload and can be sorted amongst # other ksb::Modules. use 5.014; use warnings; no if $] >= 5.018, 'warnings', 'experimental::smartmatch'; use parent qw(ksb::OptionsBase); use ksb::Debug; use ksb::Util; use ksb::Updater::Svn; use ksb::Updater::Git; use ksb::Updater::Bzr; use ksb::Updater::KDEProject; use ksb::Updater::KDEProjectMetadata; use ksb::Updater::Qt5; use ksb::BuildException 0.20; use ksb::BuildSystem 0.30; use ksb::BuildSystem::Autotools; use ksb::BuildSystem::QMake; use ksb::BuildSystem::Qt4; use ksb::BuildSystem::Qt5; use ksb::BuildSystem::KDE4; use ksb::BuildSystem::CMakeBootstrap; use ksb::BuildSystem::Meson; use ksb::ModuleSet::Null; use Mojo::Promise; use Mojo::IOLoop; use POSIX qw(_exit :errno_h); use Storable qw(dclone thaw); use Carp 'confess'; use Scalar::Util 'blessed'; use overload '""' => 'toString', # Add stringify operator. '<=>' => 'compare', ; sub new { my ($class, $ctx, $name) = @_; croak_internal ("Empty ksb::Module constructed") unless $name; my $self = ksb::OptionsBase::new($class); # If building a BuildContext instead of a ksb::Module, then the context # can't have been setup yet... my $contextClass = 'ksb::BuildContext'; if ($class ne $contextClass && (!blessed($ctx) || !$ctx->isa($contextClass))) { croak_internal ("Invalid context $ctx"); } # Clone the passed-in phases so we can be different. my $phases = dclone($ctx->phases()) if $ctx; my %newOptions = ( name => $name, scm_obj => undef, build_obj => undef, phases => $phases, context => $ctx, 'module-set' => undef, + metrics => { + time_in_phase => { }, + }, ); $self->installPhasePromises() if $class eq 'ksb::Module'; # alias our options into the build context for global vis $ctx->{build_options}->{$name} = $self->{options}; @{$self}{keys %newOptions} = values %newOptions; return $self; } sub phases { my $self = shift; return $self->{phases}; } sub moduleSet { my ($self) = @_; $self->{'module-set'} //= ksb::ModuleSet::Null->new(); return $self->{'module-set'}; } sub setModuleSet { my ($self, $moduleSet) = @_; assert_isa($moduleSet, 'ksb::ModuleSet'); $self->{'module-set'} = $moduleSet; } # Subroutine to retrieve a subdirectory path with tilde-expansion and # relative path handling. # The parameter is the option key (e.g. build-dir or log-dir) to read and # interpret. sub getSubdirPath { my ($self, $subdirOption) = @_; my $dir = $self->getOption($subdirOption); # If build-dir starts with a slash, it is an absolute path. return $dir if $dir =~ /^\//; # Make sure we got a valid option result. if (!$dir) { confess ("Reading option for $subdirOption gave empty \$dir!"); } # If it starts with a tilde, expand it out. if ($dir =~ /^~/) { $dir =~ s/^~/$ENV{'HOME'}/; } else { # Relative directory, tack it on to the end of $kdesrcdir. my $kdesrcdir = $self->getOption('source-dir'); $dir = "$kdesrcdir/$dir"; } return $dir; } # Method: getInstallPathComponents # # Returns the directory that a module should be installed in. # # NOTE: The return value is a hash. The key 'module' will return the final # module name, the key 'path' will return the full path to the module. The # key 'fullpath' will return their concatenation. # # For example, with $module == 'KDE/kdelibs', and no change in the dest-dir # option, you'd get something like: # # > { # > 'path' => '/home/user/kdesrc/KDE', # > 'module' => 'kdelibs', # > 'fullpath' => '/home/user/kdesrc/KDE/kdelibs' # > } # # If dest-dir were changed to e.g. extragear-multimedia, you'd get: # # > { # > 'path' => '/home/user/kdesrc', # > 'module' => 'extragear-multimedia', # > 'fullpath' => '/home/user/kdesrc/extragear-multimedia' # > } # # Parameters: # pathType - Either 'source' or 'build'. # # Returns: # hash (Not a hashref; See description). sub getInstallPathComponents { my $module = assert_isa(shift, 'ksb::Module'); my $type = shift; my $destdir = $module->destDir(); my $srcbase = $module->getSourceDir(); $srcbase = $module->getSubdirPath('build-dir') if $type eq 'build'; my $combined = "$srcbase/$destdir"; # Remove dup // $combined =~ s/\/+/\//; my @parts = split(/\//, $combined); my %result = (); $result{'module'} = pop @parts; $result{'path'} = join('/', @parts); $result{'fullpath'} = "$result{path}/$result{module}"; my $compatDestDir = $module->destDir($module->name()); my $fullCompatPath = "$srcbase/$compatDestDir"; # We used to have code here to migrate very old directory layouts. It was # removed as of about 2013-09-29. return %result; } # Do note that this returns the *base* path to the source directory, # without the module name or kde_projects stuff appended. If you want that # use subroutine fullpath(). sub getSourceDir { my $self = shift; return $self->getSubdirPath('source-dir'); } sub name { my $self = shift; return $self->{name}; } sub scm { my $self = shift; return $self->{scm_obj} if $self->{scm_obj}; # Look for specific setting of repository and svn-server. If both is # set it's a bug, if one is set, that's the type (because the user says # so...). Don't use getOption($key) as it will try to fallback to # global options. my $svn_status = $self->getOption('svn-server', 'module'); my $repository = $self->getOption('repository', 'module') // ''; my $rcfile = $self->buildContext()->rcFile(); if ($svn_status && $repository) { error (<{scm_obj} = ksb::Updater::Bzr->new($self); } # If it needs a repo it's git. Everything else is svn for now. $self->{scm_obj} //= $repository ? ksb::Updater::Git->new($self) : ksb::Updater::Svn->new($self); return $self->{scm_obj}; } sub setScmType { my ($self, $scmType) = @_; my $newType; given($scmType) { when('git') { $newType = ksb::Updater::Git->new($self); } when('proj') { $newType = ksb::Updater::KDEProject->new($self); } when('metadata') { $newType = ksb::Updater::KDEProjectMetadata->new($self); } # when('l10n') { $newType = ksb::l10nSystem->new($self); } when('svn') { $newType = ksb::Updater::Svn->new($self); } when('bzr') { $newType = ksb::Updater::Bzr->new($self); } when('qt5') { $newType = ksb::Updater::Qt5->new($self); } default { $newType = undef; } } $self->{scm_obj} = $newType; } # Returns a string describing the scm platform of the given module. # Return value: 'git' or 'svn' at this point, as appropriate. sub scmType { my $self = shift; return $self->scm()->name(); } sub currentScmRevision { my $self = shift; return $self->scm()->currentRevisionInternal(); } # Returns a new build system object, given the appropriate name. # This is a sub-optimal way to fix the problem of allowing users to override # the detected build system (we could instead use introspection to figure out # available build systems at runtime). However, KISS... sub buildSystemFromName { my ($self, $name) = @_; my %buildSystemClasses = ( 'generic' => 'ksb::BuildSystem', 'qmake' => 'ksb::BuildSystem::QMake', 'cmake-bootstrap' => 'ksb::BuildSystem::CMakeBootstrap', 'kde' => 'ksb::BuildSystem::KDE4', 'qt' => 'ksb::BuildSystem::Qt4', 'qt5' => 'ksb::BuildSystem::Qt5', 'autotools' => 'ksb::BuildSystem::Autotools', 'meson' => 'ksb::BuildSystem::Meson', ); my $class = $buildSystemClasses{lc $name} // undef; return $class->new($self) if ($class); # Past here, no class found croak_runtime("Invalid build system $name requested"); } sub buildSystem { my $self = shift; if ($self->{build_obj} && $self->{build_obj}->name() ne 'generic') { return $self->{build_obj}; } if (my $userBuildSystem = $self->getOption('override-build-system')) { $self->{build_obj} = $self->buildSystemFromName($userBuildSystem); return $self->{build_obj}; } # If not set, let's guess. my $buildType; my $sourceDir = $self->fullpath('source'); if (($self->getOption('repository') =~ /gitorious\.org\/qt\//) || ($self->getOption('repository') =~ /^kde:qt$/) || (-e "$sourceDir/bin/syncqt")) { $buildType = ksb::BuildSystem::Qt4->new($self); } # This test must come before the KDE buildsystem's as cmake's own # bootstrap system also has CMakeLists.txt if (!$buildType && (-e "$sourceDir/CMakeLists.txt") && (-e "$sourceDir/bootstrap")) { $buildType = ksb::BuildSystem::CMakeBootstrap->new($self); } if (!$buildType && (-e "$sourceDir/CMakeLists.txt" || $self->getOption('#xml-full-path'))) { $buildType = ksb::BuildSystem::KDE4->new($self); } # We have to assign to an array to force glob to return all results, # otherwise it acts like a non-reentrant generator whose output depends on # how many times it's been called... if (!$buildType && (my @files = glob ("$sourceDir/*.pro"))) { $buildType = ksb::BuildSystem::QMake->new($self); } # 'configure' is a popular fall-back option even for other build # systems so ensure we check last for autotools. if (!$buildType && (-e "$sourceDir/configure" || -e "$sourceDir/autogen.sh")) { $buildType = ksb::BuildSystem::Autotools->new($self); } # Someday move this up, but for now ensure that Meson happens after # configure/autotools support is checked for. if (!$buildType && -e "$sourceDir/meson.build") { $buildType = ksb::BuildSystem::Meson->new($self); } # Don't just assume the build system is KDE-based... $buildType //= ksb::BuildSystem->new($self); $self->{build_obj} = $buildType; return $self->{build_obj}; } # Sets the build system **object**, although you can find the build system # type afterwards (see buildSystemType). sub setBuildSystem { my ($self, $obj) = @_; assert_isa($obj, 'ksb::BuildSystem'); $self->{build_obj} = $obj; } # Current possible build system types: # KDE (i.e. cmake), Qt, l10n (KDE language buildsystem), autotools (either # configure or autogen.sh). A final possibility is 'pendingSource' which # simply means that we don't know yet. # # If the build system type is not set ('pendingSource' counts as being # set!) when this function is called then it will be autodetected if # possible, but note that not all possible types will be detected this way. # If in doubt use setBuildSystemType sub buildSystemType { my $self = shift; return $self->buildSystem()->name(); } # Creates the Mojo::Promises corresponding to each named phase. # E.g. the 'update' phase would be mapped to a sequence of subs to be executed # for the update. sub installPhasePromises { # Make our normal "self" a name unlikely to be used in a closure # below by mistake my $misnamedSelf = shift; # Each phase either maps directly to a subroutine which can # block (and whose return value will have a default handler), # or can map to an array of exactly 2 subroutines. The first # sub would be the blocking handler, the second sub is a # custom handler for the result. # Both subs are passed the module as the first param my %phaseBuilders = ( # Always runs, always first, the appropriate subsequent phase will # be linked to this one (based on --no-src, --install-only, etc.) start => sub { my $self = shift; my %pathinfo = $self->getInstallPathComponents('build'); super_mkdir($pathinfo{'path'}); return { was_successful => 1 }; }, # update => [ # See Application.pm for its custom runPhase_p # ], buildsystem => [ sub { my $self = shift; return { was_successful => $self->setupBuildSystem() }; }, sub { my ($self, $was_successful) = @_; return Mojo::Promise->new->reject('Unable to setup build system') unless $was_successful; return $was_successful; } ], build => [ sub { # called in child process, can block my $self = shift; # already returns a hashref in proper schema return $self->buildSystem()->buildInternal(); }, sub { # called in this process, with results my ($self, $was_successful, $extras) = @_; $self->setPersistentOption('last-build-rev', $self->currentScmRevision()); # $extras has metadata on number of warnings, but it's already # been reported by the time we get here. return 1 if $was_successful; return Mojo::Promise->new->reject('Build failed'); }, ], test => sub { my $self = shift; $self->buildSystem()->runTestsuite() if $self->getOption('run-tests'); # TODO: Make test failure a blocker for install? return { was_successful => 1 }; }, install => sub { my $self = shift; my $success = 1; $success = 0 if $self->getOption('install-after-build') and !$self->install(); return { was_successful => $success }; }, ); $misnamedSelf->{builders} = \%phaseBuilders; } # Subroutine to build this module. # Returns a promise that resolves to true (on success) or rejects with a error # string sub build { my $self = assert_isa(shift, 'ksb::Module'); my $moduleName = $self->name(); my %pathinfo = $self->getInstallPathComponents('build'); my $builddir = $pathinfo{'fullpath'}; my $buildSystem = $self->buildSystem(); return Mojo::Promise->new->reject('There is no build system to use') if ($buildSystem->name() eq 'generic' && !pretending()); # Ensure we're in a known directory before we start; some options remove # the old build directory that a previous module might have been using. super_mkdir($pathinfo{'path'}); p_chdir($pathinfo{'path'}); my $buildSystemPromise = $self->runPhase_p('buildsystem'); return $buildSystemPromise if $self->getOption('build-system-only'); # If we don't stop with the build system only, then keep extending that # promise chain to complete the build, test, and install return $buildSystemPromise->then(sub { return $self->runPhase_p('build'); })->then(sub { return $self->runPhase_p('test'); })->then(sub { return $self->runPhase_p('install'); }); } # Subroutine to setup the build system in a directory. # Returns boolean true on success, boolean false (0) on failure. sub setupBuildSystem { my $self = assert_isa(shift, 'ksb::Module'); my $moduleName = $self->name(); my $buildSystem = $self->buildSystem(); if ($buildSystem->name() eq 'generic' && !pretending()) { croak_internal('Build system determination still pending when build attempted.'); } my $refreshReason = $buildSystem->needsRefreshed(); if ($refreshReason ne "") { # Check to see if we're actually supposed to go through the # cleaning process. if (!$self->getOption('#cancel-clean') && !$buildSystem->cleanBuildSystem()) { warning ("\tUnable to clean r[$self]!"); return 0; } } if (!$buildSystem->createBuildSystem()) { error ("\tError creating r[$self]'s build system!"); return 0; } # Now we're in the checkout directory # So, switch to the build dir. # builddir is automatically set to the right value for qt p_chdir ($self->fullpath('build')); if (!$buildSystem->configureInternal()) { error ("\tUnable to configure r[$self] with " . $self->buildSystemType()); # Add undocumented ".refresh-me" file to build directory to flag # for --refresh-build for this module on next run. See also the # "needsRefreshed" subroutine. if (open my $fh, '>', '.refresh-me') { say $fh "# Build directory will be re-generated next kdesrc-build run"; say $fh "# due to failing to complete configuration on the last run"; close $fh; }; return 0; } return 1; } # Responsible for installing the module (no update, build, etc.) # Return value: Boolean flag indicating whether module installed successfully or # not. # Exceptions may be thrown for abnormal conditions (e.g. no build dir exists) sub install { my $self = assert_isa(shift, 'ksb::Module'); my $builddir = $self->fullpath('build'); my $buildSysFile = $self->buildSystem()->configuredModuleFileName(); if (!pretending() && ! -e "$builddir/$buildSysFile") { warning ("\tThe build system doesn't exist for r[$self]."); warning ("\tTherefore, we can't install it. y[:-(]."); return 0; } $self->setupEnvironment(); my @makeInstallOpts = split(' ', $self->getOption('make-install-prefix')); # We can optionally uninstall prior to installing # to weed out old unused files. if ($self->getOption('use-clean-install') && $self->getPersistentOption('last-install-rev')) { if (!$self->buildSystem()->uninstallInternal(@makeInstallOpts)) { warning ("\tUnable to uninstall r[$self] before installing the new build."); warning ("\tContinuing anyways..."); } else { $self->unsetPersistentOption('last-install-rev'); } } if (!$self->buildSystem()->installInternal(@makeInstallOpts)) { error ("\tUnable to install r[$self]!"); $self->buildContext()->markModulePhaseFailed('install', $self); return 0; } if (pretending()) { pretend ("\tWould have installed g[$self]"); return 1; } # Past this point we know we've successfully installed, for real. $self->setPersistentOption('last-install-rev', $self->currentScmRevision()); my $remove_setting = $self->getOption('remove-after-install'); # Possibly remove the srcdir and builddir after install for users with # a little bit of HD space. if($remove_setting eq 'all') { # Remove srcdir my $srcdir = $self->fullpath('source'); note ("\tRemoving b[r[$self source]."); safe_rmtree($srcdir); } if($remove_setting eq 'builddir' || $remove_setting eq 'all') { # Remove builddir note ("\tRemoving b[r[$self build directory]."); safe_rmtree($builddir); # We're likely already in the builddir, so chdir back to the root p_chdir('/'); } return 1; } # Handles uninstalling this module (or its sub-directories as given by the checkout-only # option). # # Returns boolean false on failure, boolean true otherwise. sub uninstall { my $self = assert_isa(shift, 'ksb::Module'); my $builddir = $self->fullpath('build'); my $buildSysFile = $self->buildSystem()->configuredModuleFileName(); if (!pretending() && ! -e "$builddir/$buildSysFile") { warning ("\tThe build system doesn't exist for r[$self]."); warning ("\tTherefore, we can't uninstall it."); return 0; } $self->setupEnvironment(); my @makeInstallOpts = split(' ', $self->getOption('make-install-prefix')); if (!$self->buildSystem()->uninstallInternal(@makeInstallOpts)) { error ("\tUnable to uninstall r[$self]!"); $self->buildContext()->markModulePhaseFailed('install', $self); return 0; } if (pretending()) { pretend ("\tWould have uninstalled g[$self]"); return 1; } $self->unsetPersistentOption('last-install-rev'); return 1; } sub buildContext { my $self = shift; return $self->{context}; } # Integrates 'set-env' option to the build context environment sub applyUserEnvironment { my $self = assert_isa(shift, 'ksb::Module'); my $ctx = $self->buildContext(); # Let's see if the user has set env vars to be set. # Note the global set-env must be checked separately anyways, so # we limit inheritance when searching. my $env_hash_ref = $self->getOption('set-env', 'module'); while (my ($key, $value) = each %{$env_hash_ref}) { $ctx->queueEnvironmentVariable($key, $value); } } # Establishes proper build environment in the build context. Should be run # before forking off commands for e.g. updates, builds, installs, etc. sub setupEnvironment { my $self = assert_isa(shift, 'ksb::Module'); my $ctx = $self->buildContext(); my $kdedir = $self->getOption('kdedir'); my $qtdir = $self->getOption('qtdir'); my $prefix = $self->installationPath(); # Add global set-envs and context $self->buildContext()->applyUserEnvironment(); # Ensure the platform libraries we're building can be found, as long as they # are not the system's own libraries. for my $platformDir ($qtdir, $kdedir) { next unless $platformDir; # OK, assume system platform is usable next if $platformDir eq '/usr'; # Don't 'fix' things if system platform # manually set $ctx->prependEnvironmentValue('PKG_CONFIG_PATH', "$platformDir/lib/pkgconfig"); $ctx->prependEnvironmentValue('LD_LIBRARY_PATH', "$platformDir/lib"); $ctx->prependEnvironmentValue('PATH', "$platformDir/bin"); } # Build system's environment injection my $buildSystem = $self->buildSystem(); $buildSystem->prepareModuleBuildEnvironment($ctx, $self, $prefix); # Read in user environment defines $self->applyUserEnvironment() unless $self == $ctx; } # Returns the path to the log directory used during this run for this # ksb::Module, based on an autogenerated unique id. The id doesn't change # once generated within a single run of the script. sub getLogDir { my ($self) = @_; return $self->buildContext()->getLogDirFor($self); } # Returns a full path that can be open()'d to write a log # file, based on the given basename (with extension). # Updates the 'latest' symlink as well, unlike getLogDir # Use when you know you're going to create a new log sub getLogPath { my ($self, $path) = @_; return $self->buildContext()->getLogPathFor($self, $path); } sub toString { my $self = shift; return $self->name(); } sub compare { my ($self, $other) = @_; return $self->name() cmp $other->name(); } # Throws an exception on error, otherwise returns number of updates known to # have occurred. Only returns 0 if we positively know from the scm that no # update occurred. sub update { my ($self, $ctx) = @_; my $module_src_dir = $self->getSourceDir(); my $kdesrc = $ctx->getSourceDir(); if ($kdesrc ne $module_src_dir && !super_mkdir($module_src_dir)) { # This module has a different source directory, ensure it exists. croak_runtime ("Unable to create separate source directory for $self at $module_src_dir"); } # Use 1 as default value to force a rebuild if we can't determine there # were truly *no* updates my $count = $self->scm()->updateInternal() // 1; return { was_successful => 1, update_count => $count }; } # OVERRIDE # # This calls OptionsBase::setOption and performs any Module-specific # handling. sub setOption { my ($self, %options) = @_; # Ensure we don't accidentally get fed module-set options for (qw(git-repository-base use-modules ignore-modules)) { if (exists $options{$_}) { error (" r[b[*] module b[$self] should be declared as module-set to use b[$_]"); die ksb::BuildException::Config->new($_, "Option $_ can only be used in module-set"); }; } # Special case handling. if (exists $options{'filter-out-phases'}) { for my $phase (split(' ', $options{'filter-out-phases'})) { $self->phases()->filterOutPhase($phase); } delete $options{'filter-out-phases'}; } # When running in a subprocess, option changes will be forgotten unless they are fed # back to parent process, so store those in a special array also. if (exists $self->buildContext()->{'#pending'}) { # Only forward 'plain' options, just a sanity check my @keys = grep { !ref($options{$_}) } (keys %options); $self->{options}->{'#pending'} //= { }; @{$self->{options}->{'#pending'}}{@keys} = @options{@keys}; } $self->SUPER::setOption(%options); } # OVERRIDE # # This subroutine returns an option value for a given module. Some globals # can't be overridden by a module's choice (but see 2nd parameter below). # If so, the module's choice will be ignored, and a warning will be issued. # # Option names are case-sensitive! # # Some options (e.g. cmake-options, configure-flags) have the global value # and then the module's own value appended together. To get the actual # module setting you must use the level limit parameter set to 'module'. # # Likewise, some qt module options do not obey the previous proviso since # Qt options are not likely to agree nicely with generic KDE buildsystem # options. # # 1st parameter: Name of option # 2nd parameter: Level limit (optional). If not present, then the value # 'allow-inherit' is used. Options: # - allow-inherit: Module value is used if present (with exceptions), # otherwise global is used. # - module: Only module value is used (if you want only global then use the # buildContext) NOTE: This overrides global "sticky" options as well! sub getOption { my ($self, $key, $levelLimit) = @_; my $ctx = $self->buildContext(); $levelLimit //= 'allow-inherit'; # Some global options would probably make no sense applied to Qt. my @qtCopyOverrides = qw(branch configure-flags tag cxxflags); if (list_has(\@qtCopyOverrides, $key) && $self->buildSystemType() eq 'Qt') { $levelLimit = 'module'; } assert_in($levelLimit, [qw(allow-inherit module)]); # If module-only, check that first. return $self->{options}{$key} if $levelLimit eq 'module'; my $ctxValue = $ctx->getOption($key); # we'll use this a lot from here # Some global options always override module options. return $ctxValue if $ctx->hasStickyOption($key); # Some options append to the global (e.g. conf flags) my @confFlags = qw(cmake-options configure-flags cxxflags); if (list_has(\@confFlags, $key) && $ctxValue) { return trimmed("$ctxValue " . ($self->{options}{$key} || '')); } # Everything else overrides the global option, unless it's simply not # set at all. return $self->{options}{$key} // $ctxValue; } # Gets persistent options set for this module. First parameter is the name # of the option to lookup. Undef is returned if the option is not set, # although even if the option is set, the value returned might be empty. # Note that ksb::BuildContext also has this function, with a slightly # different signature, which OVERRIDEs this function since Perl does not # have parameter-based method overloading. sub getPersistentOption { my ($self, $key) = @_; return $self->buildContext()->getPersistentOption($self->name(), $key); } # Sets a persistent option (i.e. survives between processes) for this module. # First parameter is the name of the persistent option. # Second parameter is its actual value. # See the warning for getPersistentOption above, it also applies for this # method vs. ksb::BuildContext::setPersistentOption sub setPersistentOption { my ($self, $key, $value) = @_; return $self->buildContext()->setPersistentOption($self->name(), $key, $value); } # Unsets a persistent option for this module. # Only parameter is the name of the option to unset. sub unsetPersistentOption { my ($self, $key) = @_; $self->buildContext()->unsetPersistentOption($self->name(), $key); } # Returns the path to the desired directory type (source or build), # including the module destination directory itself. sub fullpath { my ($self, $type) = @_; assert_in($type, [qw/build source/]); my %pathinfo = $self->getInstallPathComponents($type); return $pathinfo{'fullpath'}; } # Returns the "full kde-projects path" for the module. As should be obvious by # the description, this only works for modules with an scm type that is a # Updater::KDEProject (or its subclasses), but modules that don't fall into this # hierarchy will just return the module name (with no path components) anyways. sub fullProjectPath { my $self = shift; return ($self->getOption('#xml-full-path', 'module') || $self->name()); } # Returns true if this module is (or was derived from) a kde-projects module. sub isKDEProject { my $self = shift; return $self->hasOption('#xml-full-path'); } # Subroutine to return the name of the destination directory for the # checkout and build routines. Based on the dest-dir option. The return # value will be relative to the src/build dir. The user may use the # '$MODULE' or '${MODULE}' sequences, which will be replaced by the name of # the module in question. # # The first parameter is optional, but if provided will be used as the base # path to replace $MODULE entries in dest-dir. sub destDir { my $self = assert_isa(shift, 'ksb::Module'); my $destDir = $self->getOption('dest-dir'); my $basePath = ""; if ($self->getOption('ignore-kde-structure')) { $basePath = $self->name(); } else { $basePath = shift // $self->getOption('#xml-full-path'); $basePath ||= $self->name(); # Default if not provided in repo-metadata } $destDir =~ s/(\$\{MODULE})|(\$MODULE\b)/$basePath/g; return $destDir; } # Subroutine to return the installation path of a given module (the value # that is passed to the CMAKE_INSTALL_PREFIX CMake option). # It is based on the "prefix" and, if it is not set, the "kdedir" option. # The user may use '$MODULE' or '${MODULE}' in the "prefix" option to have # them replaced by the name of the module in question. sub installationPath { my $self = assert_isa(shift, 'ksb::Module'); my $path = $self->getOption('prefix'); if (!$path) { return $self->getOption('kdedir'); } my $moduleName = $self->name(); $path =~ s/(\$\{MODULE})|(\$MODULE\b)/$moduleName/g; return $path; } # Supports the subprocess handler in runPhase_p by reading messages that were # generated by the child process and sent back to us, and dispatching to # handler for real-time updates. Messages that can wait until the subprocess is # complete are handled separately. sub _readAndDispatchInProcessMessages { my ($self, $frozen_message, $monitor, $phaseName) = @_; my $linesRef = eval { thaw($frozen_message) }; croak_internal("Failed to read msg from child handler: $@") unless $linesRef; if (exists $linesRef->{message}) { $monitor->noteLogEvents("$self", $phaseName, [$linesRef->{message}]); } elsif (exists $linesRef->{progress}) { my ($x, $y) = @{$linesRef->{progress}}; $monitor->markPhaseProgress("$self", $phaseName, $x / $y) if $y > 0; } else { croak_internal("Couldn't handle message $frozen_message from child."); } } # Runs the given phase in a separate subprocess, using provided sub references. # Assumes use of promises for the provided sub references -- if launching the # subprocess fails, then a rejected promise is returned in the completion sub # reference # Returns a promise that yields the return value of the completion sub # reference. sub runPhase_p { my ($self, $phaseName, $blocking_coderef, $completion_coderef) = @_; my $phaseSubs = $self->{builders}->{$phaseName}; if (ref($phaseSubs) eq 'CODE') { $blocking_coderef //= $phaseSubs; } elsif (ref($phaseSubs) eq 'ARRAY') { ($blocking_coderef, $completion_coderef) = @{$phaseSubs}; croak_internal("Missing subs for $phaseName") unless ($blocking_coderef && $completion_coderef); } else { croak_internal("self->builders->{$phaseName} should not be set") if defined $phaseSubs; } # Default handler $completion_coderef //= sub { my ($module, $result, $extras) = (@_); return Mojo::Promise->new->reject unless $result; return $result; }; my $promise = Mojo::Promise->new; my $ctx = $self->buildContext(); pipe (my $reader, my $writer) or croak_runtime("Couldn't open pipe to subprocess for $phaseName: $!"); # Setup a pipe from child to parent so we can get updates as the phase # progresses, logs, etc. my $reactor = Mojo::IOLoop->singleton->reactor; my $monitor = $self->buildContext()->statusMonitor(); my $reactorPromise = Mojo::Promise->new; $reactor->io($reader => sub { my ($reactor) = @_; my $buffer; if ((my $lengthRead = $reader->sysread($buffer, 8192)) == 0) { # eof $reactor->remove($reader); close $reader; $reactorPromise->resolve; } elsif ($lengthRead > 0) { $self->_readAndDispatchInProcessMessages($buffer, $monitor, $phaseName); } else { croak_runtime("Error reading from child pipe: $!"); $reactorPromise->reject; } }); $reactor->watch($reader, 1, 0); # watch for pipe readability only $monitor->markPhaseStart($self->name(), $phaseName); + my $start_time = time; Mojo::IOLoop->subprocess( sub { # blocks, runs in separate process $SIG{INT} = sub { POSIX::_exit(EINTR); }; $0 = "kdesrc-build[$phaseName]"; # This causes setOption to record changes, and is deliberately not # within ctx->{options} $ctx->{'#pending'} = { }; $writer->autoflush(1); close $reader; # we can't use this anyways ksb::Debug::setOutputHandle($writer); $self->buildContext->resetEnvironment(); $self->setupEnvironment(); # This coderef should return a hashref: { # was_successful => bool, # ... (other details) # } my $resultRef = $blocking_coderef->($self); my $result = $resultRef->{was_successful}; my %newOptions; # Grab any newly-set options to feed back to parent my @affectedMods = grep { exists $ctx->{build_options}->{$_}->{'#pending'}; } (keys %{$ctx->{build_options}}); foreach my $affected (@affectedMods) { $newOptions{$affected} = $ctx->{build_options}->{$affected}->{'#pending'}; } return { result => $result, newOptions => \%newOptions, extras => $resultRef, }; }, sub { # runs in this process once subprocess is done my ($subprocess, $err, $resultsRef) = @_; close $writer; # can't close it earlier because must be open at fork if ($err) { $ctx->markModulePhaseFailed($phaseName, $self); return $promise->reject($err); } + $self->{metrics}->{time_in_phase}->{$phaseName} = time - $start_time; + # Apply options that may have changed during child proc execution. if (%{$resultsRef->{newOptions}}) { while(my ($k, $v) = each %{$resultsRef->{newOptions}}) { my %modulesNewOptions = %{$v}; @{$ctx->{build_options}->{$k}}{keys %modulesNewOptions} = values %modulesNewOptions; } } my $result = $resultsRef->{result}; if ($result) { $ctx->markModulePhaseSucceeded($phaseName, $self, $resultsRef->{extras}); } else { $ctx->markModulePhaseFailed($phaseName, $self); } return $reactorPromise->then(sub { # This coderef should resolve or reject the promise, if used $result ? $promise->resolve($completion_coderef->($self, $result, $resultsRef)) : $promise->reject ($completion_coderef->($self, $result, $resultsRef)); }); } ); return $promise; } 1; diff --git a/modules/ksb/StatusView.pm b/modules/ksb/StatusView.pm index 5f24cfd..a0c6355 100644 --- a/modules/ksb/StatusView.pm +++ b/modules/ksb/StatusView.pm @@ -1,416 +1,440 @@ package ksb::StatusView 0.30; use utf8; # Source code is utf8-encoded # Helper used to handle a generic 'progress update' status for the module # build, update, install, etc. processes. # # Currently supports TTY output only but it's not impossible to visualize # extending this to a GUI or even web server as options. use strict; use warnings; use 5.014; # our output to STDOUT should match locale (esp UTF-8 locale, which induces # warnings for UTF-8 output unless we specifically opt-in) use open OUT => ':locale'; use ksb::Debug 0.20 qw(colorize); use ksb::Util; use ksb::BuildException; use List::Util qw(min max reduce first); use IO::Handle; sub new { my $class = shift; my $tty_width = int(`tput cols` // $ENV{COLUMNS} // 80); my $defaultOpts = { tty_width => $tty_width, max_name_width => 1, # Updated from the build plan cur_update => '', # moduleName under update cur_working => '', # moduleName under any other phase cur_progress => '', # Percentage (0% - 100%) module_in_phase => { }, # $phase -> $moduleName done_in_phase => { }, # $phase -> int todo_in_phase => { }, # $phase -> int failed_at_phase => { }, # $moduleName -> $phase log_entries => { }, # $moduleName -> $phase -> [ $entry ... ] last_mod_entry => '', # $moduleName/$phase, see onLogEntries last_msg_type => '', # If 'progress' we can clear line }; # Must bless a hash ref since subclasses expect it. return bless $defaultOpts, $class; } # Accepts a single event, as a hashref decoded from its source JSON format (as # described in ksb::StatusMonitor), and updates the user interface # appropriately. sub notifyEvent { my ($self, $ev) = @_; state $handlers = { phase_started => \&onPhaseStarted, phase_progress => \&onPhaseProgress, phase_completed => \&onPhaseCompleted, build_plan => \&onBuildPlan, build_done => \&onBuildDone, log_entries => \&onLogEntries, }; state $err = sub { croak_internal("Invalid event! $_[1]"); }; my $handler = $handlers->{$ev->{event}} // $err; # This is a method call though we don't use normal Perl method call syntax $handler->($self, $ev); } # Event handlers # A module has started on a given phase. Multiple phases can be in-flight at # once! sub onPhaseStarted { my ($self, $ev) = @_; my ($moduleName, $phase) = @{$ev->{phase_started}}{qw/module phase/}; $self->{module_in_phase}->{$phase} = $moduleName; my $phaseKey = $phase eq 'update' ? 'cur_update' : 'cur_working'; $self->{$phaseKey} = $moduleName; $self->update(); } # Progress has been made within a phase of a module build. Only supported for # the build phase, currently. sub onPhaseProgress { my ($self, $ev) = @_; my ($moduleName, $phase, $progress) = @{$ev->{phase_progress}}{qw/module phase progress/}; $progress = sprintf ("%3.1f", 100.0 * $progress); $self->{cur_progress} = $progress; $self->update(); } -# A phase of a module build is finished -sub onPhaseCompleted +# Writes out a line to TTY noting information about the module that just finished +# (elapsed time, compile warnings, success/failure, etc.) +# Pass in the monitor event for the 'phase_completed' event +sub _showModuleFinishResults { my ($self, $ev) = @_; my ($moduleName, $phase, $result) = @{$ev->{phase_completed}}{qw/module phase result/}; my $modulePhasePlan = $self->{planned_phases}->{$moduleName}; - $self->_checkForBuildPlan(); - - $modulePhasePlan->{$phase} = $result - unless ($modulePhasePlan->{$phase} // '') eq 'skipped'; - - if ($result eq 'error') { - $self->{failed_at_phase}->{$moduleName} = $phase; - while (my ($phase, $result) = each %{$modulePhasePlan}) { - $modulePhasePlan->{$phase} = 'skipped' if $result eq 'pending'; - } - } - - $self->{done_in_phase}->{$phase}++; - my $phase_done = ( - ($self->{done_in_phase}->{$phase} // 0) == - ($self->{todo_in_phase}->{$phase} // 999)); - my %shortPhases = ( update => 'Upd', buildsystem => 'Cnf', build => 'Bld', test => 'Tst', install => 'Ins', uninstall => 'Uns', ); my %resultColors = ( 'success' => 'g', 'error' => 'r', 'skipped' => 'y', 'pending' => 'y', ); + # Locate this module's specific build plan from the ordered array + my $modulePlan = + first { $_->{name} eq $moduleName } + @{$self->{build_plan}}; + + # Turn each planned phase into a colorized representation of its success or failure + my $done_phases = + join(' / ', + map { my $clr = $resultColors{$modulePhasePlan->{$_}} // 'y'; "$clr" . "[$shortPhases{$_}]" } + @{$modulePlan->{phases}}); + + my $overallColor = $resultColors{$result} // ''; + + # Space out module names so that the whole list is table-aligned + my $fixedLengthName = sprintf("%-*s", $self->{max_name_width}, $moduleName); + + my $printedTime = prettify_seconds($ev->{phase_completed}->{elapsed} // 0); + + $self->_clearLineAndUpdate(colorize(" ${overallColor}[b[*] Completed b[$fixedLengthName] $printedTime $done_phases\n")); +} + +# A phase of a module build is finished +sub onPhaseCompleted +{ + my ($self, $ev) = @_; + my ($moduleName, $phase, $result) = + @{$ev->{phase_completed}}{qw/module phase result/}; + my $modulePhasePlan = $self->{planned_phases}->{$moduleName}; + + $self->_checkForBuildPlan(); + + $modulePhasePlan->{$phase} = $result; + + if ($result eq 'error') { + $self->{failed_at_phase}->{$moduleName} = $phase; + + # The phases should all eventually become failed but we should + # still flag them here in case they don't + while (my ($phase, $result) = each %{$modulePhasePlan}) { + $modulePhasePlan->{$phase} = 'skipped' if $result eq 'pending'; + } + } + # Are we completely done building the module? if (!first { $_ eq 'pending' } values %{$modulePhasePlan}) { - my $modulePlan = - first { $_->{name} eq $moduleName } - @{$self->{build_plan}}; - my $fixedLengthName = sprintf("%-*s", $self->{max_name_width}, $moduleName); - my $done_phases = - join(' / ', - map { my $ok = $modulePhasePlan->{$_} ne 'success' ? 'r' : 'g'; "$ok" . "[$shortPhases{$_}]" } - @{$modulePlan->{phases}}); - - my $overallColor = $resultColors{$result} // ''; - $self->_clearLineAndUpdate(colorize(" ${overallColor}[b[*] Completed b[$fixedLengthName] $done_phases\n")); + $self->_showModuleFinishResults($ev); } + # Update global progress bar + $self->{done_in_phase}->{$phase}++; + my $phase_done = ( + ($self->{done_in_phase}->{$phase} // 0) == + ($self->{todo_in_phase}->{$phase} // 999)); + my $phaseKey = $phase eq 'update' ? 'cur_update' : 'cur_working'; $self->{$phaseKey} = $phase_done ? '---' : ''; $self->update(); } # The one-time build plan has been given, can be used for deciding best way to # show progress # # Looks like: # { # "build_plan": [ # { # "name": "juk", # "phases": [ # "build", # "install" # ] # } # ], # "event": "build_plan" # } sub onBuildPlan { my ($self, $ev) = @_; my (@modules) = @{$ev->{build_plan}}; croak_internal ("Empty build plan!") unless @modules; croak_internal ("Already received a plan!") if exists $self->{planned_phases}; my %num_todo = ( # These are the 'core' phases we expect to be here even with # --no-src, --no-build, etc. update => 0, build => 0, ); my $max_name_width = 0; $self->{planned_phases} = { }; for my $m (@modules) { my @phases = @{$m->{phases}}; $max_name_width = max($max_name_width, length $m->{name}); $num_todo{$_}++ foreach @phases; $self->{planned_phases}->{$m->{name}} = { map { ($_, 'pending') } @phases }; } $self->{done_in_phase}->{$_} = 0 foreach keys %num_todo; $self->{todo_in_phase} = \%num_todo; $self->{max_name_width} = $max_name_width; $self->{build_plan} = $ev->{build_plan}; } # The whole build/install process has completed. sub onBuildDone { my ($self, $ev) = @_; my ($statsRef) = %{$ev->{build_done}}; # --stop-on-failure can cause modules to skip my $numTotalModules = max( map { $self->{todo_in_phase}->{$_} } ( keys %{$self->{todo_in_phase}})); my $numFailedModules = keys %{$self->{failed_at_phase}}; my $numBuiltModules = max( map { $self->{done_in_phase}->{$_} } ( keys %{$self->{done_in_phase}})); my $numSuccesses = $numBuiltModules - $numFailedModules; my $numSkipped = $numTotalModules - $numBuiltModules; my $unicode = ($ENV{LC_ALL} // 'C') =~ /UTF-?8$/; my $happy = $unicode ? '✓' : ':-)'; my $frown = $unicode ? '✗' : ':-('; my $built = $numFailedModules == 0 ? " g[b[$happy] - Built all" : " r[b[$frown] - Worked on"; my $msg = "$built b[$numTotalModules] modules"; if ($numSkipped > 0 || $numFailedModules > 0) { $msg .= " (b[g[$numSuccesses] built OK, b[r[$numFailedModules] failed" if $numFailedModules > 0; $msg .= ", b[$numSkipped] skipped" if $numSkipped > 0; $msg .= ")"; } $self->_clearLineAndUpdate (colorize("$msg\n")); } # The build/install process has forwarded new notices that should be shown. sub onLogEntries { my ($self, $ev) = @_; my ($module, $phase, $entriesRef) = @{$ev->{log_entries}}{qw/module phase entries/}; # Current line may have a transient update msg still, otherwise we're already on # suitable line to print _clearLine() if $self->{last_msg_type} eq 'progress'; if ("$module/$phase" ne $self->{last_mod_entry} && @$entriesRef) { say colorize(" b[y[*] b[$module] $phase:"); $self->{last_mod_entry} = "$module/$phase"; } for my $entry (@$entriesRef) { say $entry; $self->{log_entries}->{$module} //= { build => [ ], update => [ ] }; $self->{log_entries}->{$module}->{$phase} //= [ ]; push @{$self->{log_entries}->{$module}->{$phase}}, $entry; } $self->{last_msg_type} = 'log'; $self->update(); } # TTY helpers sub _checkForBuildPlan { my $self = shift; croak_internal ("Did not receive build plan!") unless keys %{$self->{todo_in_phase}}; } # Generates a string like "update [20/74] build [02/74]" for the requested # phases. sub _progressStringForPhases { my ($self, @phases) = @_; my $result = ''; my $base = ''; foreach my $phase (@phases) { my $cur = $self->{done_in_phase}->{$phase} // 0; my $max = $self->{todo_in_phase}->{$phase} // 0; my $strWidth = length("$max"); my $progress = sprintf("%0*s/$max", $strWidth, $cur); $result .= "$base$phase [$progress]"; $base = ' '; } return $result; } # Generates a string like "update: kcoreaddons build: kconfig" for the # requested phases. You must pass in a hashref mapping each phase name to the # current module name. sub _currentModuleStringForPhases { my ($self, $currentModulesRef, @phases) = @_; my $result = ''; my $base = ''; my $longestNameWidth = $self->{max_name_width}; for my $phase (@phases) { my $curModule = $currentModulesRef->{$phase} // '???'; $curModule .= (' ' x ($longestNameWidth - length ($curModule))); $result .= "$base$phase: $curModule"; $base = ' '; } return $result; } # Returns integer length of the worst-case output line (i.e. the one with a # long module name for each of the given phases). sub _getMinimumOutputWidth { my ($self, @phases) = @_; my $longestName = 'x' x $self->{max_name_width}; my %mockModules = map { ($_, $longestName) } @phases; # fake that the worst-case module is set and find resultant length my $str = $self->_progressStringForPhases(@phases) . " " . $self->_currentModuleStringForPhases(\%mockModules, @phases); return length($str); } sub update { my @phases = qw(update build); my $self = shift; my $term_width = $self->{tty_width}; $self->{min_output} //= $self->_getMinimumOutputWidth(@phases); my $min_width = $self->{min_output}; my $progress = $self->_progressStringForPhases(@phases); my $current_modules = $self->_currentModuleStringForPhases( { update => $self->{cur_update}, build => $self->{cur_working} }, @phases ); my $msg; if ($min_width >= ($term_width - 12)) { # No room for fancy progress, just display what we can $msg = "$progress $current_modules"; } else { my $max_prog_width = ($term_width - $min_width) - 5; my $num_all_done = min(@{$self->{done_in_phase}}{@phases}) // 0; my $num_some_done = max(@{$self->{done_in_phase}}{@phases}, 0) // 0; my $max_todo = max(@{$self->{todo_in_phase}}{@phases}, 1) // 1; my $width = $max_prog_width * $num_all_done / $max_todo; # Leave at least one empty space if we're not fully done $width-- if ($width == $max_prog_width && $num_all_done < $max_todo); my $bar = ('=' x $width); # Show a smaller character entry for updates that are done before the # corresponding build/install. if ($num_some_done > $num_all_done) { $width = $max_prog_width * $num_some_done / $max_todo; $bar .= ('.' x ($width - length ($bar))); } $msg = sprintf("%s [%*s] %s", $progress, -$max_prog_width, $bar, $current_modules); } $self->_clearLineAndUpdate($msg); $self->{last_msg_type} = 'progress'; } sub _clearLine { print "\e[1G\e[K"; } sub _clearLineAndUpdate { my ($self, $msg) = @_; # If last message was a transient progress meter, gives the escape sequence # to return to column 1 and clear the entire line before printing message $msg = "\e[1G\e[K$msg" if $self->{last_msg_type} eq 'progress'; print $msg; STDOUT->flush; $self->{last_msg_type} = 'log'; # update() will change it back if needed } 1; diff --git a/modules/ksb/Util.pm b/modules/ksb/Util.pm index 6a36d90..78ce15f 100644 --- a/modules/ksb/Util.pm +++ b/modules/ksb/Util.pm @@ -1,707 +1,679 @@ package ksb::Util 0.30; # Useful utilities, which are exported into the calling module's namespace by default. use 5.014; # Needed for state keyword use strict; use warnings; use Scalar::Util qw(blessed); use File::Path qw(make_path); use File::Find; use Cwd qw(getcwd); use Errno qw(:POSIX); use Digest::MD5; use ksb::Debug; use ksb::Version qw(scriptVersion); use ksb::BuildException; use Exporter qw(import); # Use Exporter's import method our @EXPORT = qw(list_has assert_isa assert_in any unique_items absPathToExecutable fileDigestMD5 log_command disable_locale_message_translation trimmed split_quoted_on_whitespace safe_unlink safe_system p_chdir pretend_open safe_rmtree get_list_digest is_dir_empty super_mkdir filter_program_output prettify_seconds); # Function to work around a Perl language limitation. # First parameter is a reference to the list to search. ALWAYS. # Second parameter is the value to search for. # Returns true if the value is in the list sub list_has { my ($listRef, $value) = @_; my @list = @{$listRef}; return scalar grep { "$_" eq "$value" } (@list); } # Subroutine to return the path to the given executable based on the # either the given paths or the current PATH. # E.g.: # absPathToExecutable('make') -> '/usr/bin/make' # absPathToExecutable('make', 'foo', 'bar') -> /foo/make # If the executable is not found undef is returned. # # This assumes that the module environment has already been updated since # binpath doesn't exactly correspond to $ENV{'PATH'}. sub absPathToExecutable { my ($prog, @preferred) = @_; # If it starts with a / the path is already absolute. return $prog if $prog =~ /^\//; my @paths = @preferred ? @preferred : split(/:/, $ENV{'PATH'}); for my $path (@paths) { return "$path/$prog" if (-x "$path/$prog"); } return undef; } # Throws an exception if the first parameter is not an object at all, or if # it is not an object of the type given by the second parameter (which # should be a string of the class name. There is no return value; sub assert_isa { my ($obj, $class) = @_; if (!blessed($obj) || !$obj->isa($class)) { croak_internal("$obj is not of type $class, but of type " . ref($obj)); } return $obj; } # Throws an exception if the first parameter is not included in the # provided list of possible alternatives. The list of alternatives must # be passed as a reference, as the second parameter. sub assert_in { my ($val, $listRef) = @_; if (!list_has($listRef, $val)) { croak_runtime("$val is not a permissible value for its argument"); } return $val; } # Subroutine to unlink the given symlink if global-pretend isn't set. sub safe_unlink { if (pretending()) { pretend ("\tWould have unlinked ", shift, "."); return 1; # Return true } return unlink (shift); } # Subroutine to execute the system call on the given list if the pretend # global option is not set. # # Returns the shell error code, so 0 means success, non-zero means failure. sub safe_system(@) { if (!pretending()) { whisper ("\tExecuting g['", join("' '", @_), "'"); return system (@_) >> 8; } pretend ("\tWould have run g['" . join("' '", @_) . "'"); return 0; # Return true } # Is exactly like "chdir", but it will also print out a message saying that # we're switching to the directory when debugging. sub p_chdir($) { my $dir = shift; debug ("\tcd g[$dir]\n"); chdir ($dir) or do { return 1 if pretending(); croak_runtime("Could not change to directory $dir: $!"); }; } # Helper subroutine to create a directory, including any parent # directories that may also need created. # Throws an exception on failure. See File::Path. sub super_mkdir { my $pathname = shift; state %createdPaths; if (pretending()) { if (!exists $createdPaths{$pathname} && ! -e $pathname) { pretend ("\tWould have created g[$pathname]"); } $createdPaths{$pathname} = 1; return 1; } else { make_path($pathname); return (-e $pathname) ? 1 : 0; } } # Calculates the MD5 digest of a file already on-disk. The digest is # returned as a hex string digest as from Digest::MD5::md5_hex # # First parameter: File name to read # Return value: hex string MD5 digest of file. # An exception is thrown if an error occurs reading the file. sub fileDigestMD5 { my $fileName = shift; my $md5 = Digest::MD5->new; open my $file, '<', $fileName or croak_runtime( "Unable to open $fileName: $!"); binmode($file); $md5->addfile($file); return $md5->hexdigest(); } # This function is intended to disable the message translation catalog # settings in the program environment, so that any child processes executed # will have their output untranslated (and therefore scrapeable). # # As such this should only be called for a forked child about to exec as # there is no easy way to undo this within the process. sub disable_locale_message_translation { # Ensure that program output is untranslated by setting 'C' locale. # We're really trying to affect the LC_MESSAGES locale category, but # LC_ALL is a catch-all for that (so needs to be unset if set). # # Note that the ONLY SUPPORTED way to pass file names, command-line # args, etc. to commands is under the UTF-8 encoding at this point, as # that is the only sane way for this en_US-based developer to handle # the task. Patches (likely using Encode::Locale) are accepted. :P $ENV{'LC_MESSAGES'} = 'C'; if ($ENV{'LC_ALL'}) { $ENV{'LANG'} = $ENV{'LC_ALL'}; # This is lower-priority "catch all" delete $ENV{'LC_ALL'}; } } # Returns an array of lines output from a program. Use this only if you # expect that the output will be short. # # Since there is no way to disambiguate no output from an error, this # function will call die on error, wrap in eval if this bugs you. # # First parameter is subroutine reference to use as a filter (this sub will # be passed a line at a time and should return true if the line should be # returned). If no filtering is desired pass 'undef'. # # Second parameter is the program to run (either full path or something # accessible in $PATH). # # All remaining arguments are passed to the program. # # Return value is an array of lines that were accepted by the filter. sub filter_program_output { my ($filterRef, $program, @args) = @_; $filterRef //= sub { return 1 }; # Default to all lines debug ("Slurping '$program' '", join("' '", @args), "'"); # Check early for whether an executable exists since otherwise # it is possible for our fork-open below to "succeed" (i.e. fork() # happens OK) and then fail when it gets to the exec(2) syscall. if (!absPathToExecutable($program)) { croak_runtime("Can't find $program in PATH!"); } my $execFailedError = "\t - kdesrc-build - exec failed!\n"; my $pid = open(my $childOutput, '-|'); croak_internal("Can't fork: $!") if ! defined($pid); if ($pid) { # parent my @lines = grep { &$filterRef; } (<$childOutput>); close $childOutput or do { # $! indicates a rather grievous error croak_internal("Unable to open pipe to read $program output: $!") if $!; # we can pass serious errors back to ourselves too. my $exitCode = $? >> 8; if ($exitCode == 99 && @lines >= 1 && $lines[0] eq $execFailedError) { croak_runtime("Failed to exec $program, is it installed?"); } # other errors might still be serious but don't need a backtrace if (pretending()) { whisper ("$program gave error exit code $exitCode"); } else { warning ("$program gave error exit code $exitCode"); } }; return @lines; } else { disable_locale_message_translation(); # We don't want stderr output on tty. open (STDERR, '>', '/dev/null') or close (STDERR); exec { $program } ($program, @args) or do { # Send a message back to parent print $execFailedError; exit 99; # Helper proc, so don't use finish(), just die }; } } # Subroutine to return a string suitable for displaying an elapsed time, -# (like a stopwatch) would. The first parameter is the number of seconds -# elapsed. +# (like a stopwatch) would, in a fixed format HH:MM:SS. The first parameter is +# the number of seconds elapsed. sub prettify_seconds { - my $elapsed = $_[0]; - my $str = ""; - my ($days,$hours,$minutes,$seconds,$fraction); + my $elapsed = shift; + my ($hours, $minutes, $seconds); - $fraction = int (100 * ($elapsed - int $elapsed)); - $elapsed = int $elapsed; + return "(00:00:00)" if $elapsed <= 0; - $seconds = $elapsed % 60; + $seconds = int $elapsed % 60; $elapsed = int $elapsed / 60; - $minutes = $elapsed % 60; - $elapsed = int $elapsed / 60; - - $hours = $elapsed % 24; - $elapsed = int $elapsed / 24; - - $days = $elapsed; + $minutes = $elapsed % 60; + $hours = int $elapsed / 60; - $seconds = "$seconds.$fraction" if $fraction; - - my @str_list; - - for (qw(days hours minutes seconds)) - { - # Use a symbolic reference without needing to disable strict refs. - # I couldn't disable it even if I wanted to because these variables - # aren't global or localized global variables. - my $value = eval "return \$$_;"; - my $text = $_; - $text =~ s/s$// if $value == 1; # Make singular - - push @str_list, "$value $text" if $value or $_ eq 'seconds'; - } - - # Add 'and ' in front of last element if there was more than one. - push @str_list, ("and " . pop @str_list) if (scalar @str_list > 1); - - $str = join (", ", @str_list); - - return $str; + return sprintf("(%02d:%02d:%02d)", $hours, $minutes, $seconds); } # Subroutine to mark a file as being the error log for a module. This also # creates a symlink in the module log directory for easy viewing. # First parameter is the module in question. # Second parameter is the filename in the log directory of the error log. sub _setErrorLogfile { my $module = assert_isa(shift, 'ksb::Module'); my $logfile = shift; return unless $logfile; my $logdir = $module->getLogDir(); $module->setOption('#error-log-file', "$logdir/$logfile"); debug ("Logfile for $module is $logfile"); # Setup symlink in the module log directory pointing to the appropriate # file. Make sure to remove it first if it already exists. unlink("$logdir/error.log") if -l "$logdir/error.log"; if(-e "$logdir/error.log") { # Maybe it was a regular file? error ("r[b[ * Unable to create symlink to error log file]"); return; } symlink "$logfile", "$logdir/error.log"; } # Subroutine to run a command, optionally filtering on the output of the child # command. # # First parameter is the module object being built (for logging purposes # and such). # Second parameter is the name of the log file to use (relative to the log # directory). # Third parameter is a reference to an array with the command and its # arguments. i.e. ['command', 'arg1', 'arg2'] # # After the required three parameters you can pass a hash reference of # optional features: # 'callback' => a reference to a subroutine to have each line # of child output passed to. This output is not supposed to be printed # to the screen by the subroutine, normally the output is only logged. # However this is useful for e.g. munging out the progress of the build. # USEFUL: When there is no more output from the child, the callback will be # called with an undef string. (Not just empty, it is also undefined). # # 'no_translate' => any true value will cause a flag to be set to request # the executed child process to not translate (for locale purposes) its # output, so that it can be screen-scraped. # # The return value is the shell return code, so 0 is success, and non-zero is # failure. # # NOTE: This function has a special feature. If the command passed into the # argument reference is 'kdesrc-build', then log_command will, when it # forks, execute the subroutine named by the second parameter rather than # executing a child process. The subroutine should include the full package # name as well (otherwise the package containing log_command's implementation # is used). The remaining arguments in the list are passed to the # subroutine that is called. sub log_command { my ($module, $filename, $argRef, $optionsRef) = @_; assert_isa($module, 'ksb::Module'); my @command = @{$argRef}; $optionsRef //= { }; my $callbackRef = $optionsRef->{'callback'}; debug ("log_command(): Module $module, Command: ", join(' ', @command)); ksb_debug_inspect('log_command', "$module", $filename, $argRef, $optionsRef); if (pretending()) { pretend ("\tWould have run g['" . join ("' '", @command) . "'"); return 0; } # Do this before we fork so we can see errors my $logpath = $module->getLogPath("$filename.log"); # Fork a child, with its stdout connected to CHILD. my $pid = open(CHILD, '-|'); if ($pid) { # Parent if (!$callbackRef && debugging()) { # If no other callback given, pass to debug() if debug-mode is on. while () { print ($_) if $_; } } if ($callbackRef) { &{$callbackRef}($_) while (); # Let callback know there is no more output. &{$callbackRef}(undef); } # This implicitly does a waitpid() as well close CHILD or do { if ($! == 0) { _setErrorLogfile($module, "$filename.log"); return $?; } return 1; }; return 0; } else { # Child. Note here that we need to avoid running our exit cleanup # handlers in here. For that we need POSIX::_exit. # Apply altered environment variables. $module->buildContext()->commitEnvironmentChanges(); $SIG{PIPE} = "IGNORE"; $SIG{INT} = sub { close (STDOUT); # This should be a pipe close (STDERR); POSIX::_exit(EINTR); }; # Redirect STDIN to /dev/null so that the handle is open but fails when # being read from (to avoid waiting forever for e.g. a password prompt # that the user can't see. open (STDIN, '<', "/dev/null") unless exists $ENV{'KDESRC_BUILD_USE_TTY'}; if ($callbackRef || debugging()) { open (STDOUT, "|tee $logpath") or do { error ("Error opening pipe to tee command."); # Don't abort, hopefully STDOUT still works. }; } else { open (STDOUT, '>', $logpath) or do { error ("Error $! opening log to $logpath!"); }; } # Make sure we log everything. open (STDERR, ">&STDOUT"); # Call internal function, name given by $command[1] if ($command[0] eq 'kdesrc-build') { # No colors! ksb::Debug::setColorfulOutput(0); debug ("Calling $command[1]"); my $cmd = $command[1]; splice (@command, 0, 2); # Remove first two elements. no strict 'refs'; # Disable restriction on symbolic subroutines. if (! &{$cmd}(@command)) # Call sub { POSIX::_exit (EINVAL); } POSIX::_exit (0); # Exit child process successfully. } # Don't leave empty output files, give an indication of the particular # command run. Use print to go to stdout. say "# kdesrc-build running: '", join("' '", @command), "'"; say "# from directory: ", getcwd(); # If a callback is set assume no translation can be permitted. disable_locale_message_translation() if $optionsRef->{'no_translate'}; # External command. exec (@command) or do { my $cmd_string = join(' ', @command); error (<($_) && return 1) foreach @{$listRef}; return 0; } # Returns unique items of the list. Order not guaranteed. sub unique_items { # See perlfaq4 my %seen; my @results = grep { ! $seen{$_}++; } @_; return @results; } # Subroutine to delete a directory and all files and subdirectories within. # Does nothing in pretend mode. An analog to "rm -rf" from Linux. # Requires File::Find module. # # First parameter: Path to delete # Returns boolean true on success, boolean false for failure. sub safe_rmtree { my $path = shift; # Pretty user-visible path my $user_path = $path; $user_path =~ s/^$ENV{HOME}/~/; my $delete_file_or_dir = sub { # $_ is the filename/dirname. return if $_ eq '.' or $_ eq '..'; if (-f $_ || -l $_) { unlink ($_) or croak_runtime("Unable to delete $File::Find::name: $!"); } elsif (-d $_) { rmdir ($File::Find::name) or croak_runtime("Unable to remove directory $File::Find::name: $!"); } }; if (pretending()) { pretend ("Would have removed all files/folders in $user_path"); return 1; } # Error out because we probably have a logic error even though it would # delete just fine. if (not -d $path) { error ("Cannot recursively remove $user_path, as it is not a directory."); return 0; } eval { $@ = ''; finddepth( # finddepth does a postorder traversal. { wanted => $delete_file_or_dir, no_chdir => 1, # We'll end up deleting directories, so prevent this. }, $path); }; if ($@) { error ("Unable to remove directory $user_path: $@"); return 0; } return 1; } # Returns a hash digest of the given options in the list. The return value is # base64-encoded at this time. # # Note: Don't be dumb and pass data that depends on execution state as the # returned hash is almost certainly not useful for whatever you're doing with # it. (i.e. passing a reference to a list is not helpful, pass the list itself) # # Parameters: List of scalar values to hash. # Return value: base64-encoded hash value. sub get_list_digest { use Digest::MD5 "md5_base64"; # Included standard with Perl 5.8 return md5_base64(@_); } # Utility function to see if a directory path is empty or not sub is_dir_empty { my $dir = shift; opendir my $dirh, $dir or return; # while-readdir needs Perl 5.12 while (readdir $dirh) { next if ($_ eq '.' || $_ eq '..'); closedir ($dirh); return; # not empty } closedir ($dirh); return 1; } # Takes in a string and returns 1 if that string exists somewhere in the # path variable. sub isInPath { if (index($ENV{'PATH'}, $_[0]) != -1) { return 1; } else { return 0; } } # Takes in a string and returns 1 if that string exists as a line in the # ~/.bashrc file. sub fileHasLine { my $found = 0; open(my $bashrc, '<', $_[0]) or _croak_runtime("Couldn't open ~/.bashrc: $!"); while (my $line = <$bashrc>) { if (index($line, $_[1]) == 0){ return 1; } } return 0; } 1;