diff --git a/modules/ksb/BuildContext.pm b/modules/ksb/BuildContext.pm index ad0b90a..3469e8d 100644 --- a/modules/ksb/BuildContext.pm +++ b/modules/ksb/BuildContext.pm @@ -1,1038 +1,1039 @@ package ksb::BuildContext 0.35; # 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 JSON::PP; # 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; use ksb::KDEProjectsReader 0.50; use File::Temp qw(tempfile); use File::Spec; # rel2abs 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 "checkout-only" => "", "colorful-output" => 1, # Use color by default. "debug-level" => ksb::Debug::INFO, "filter-out-phases" => '', "git-desired-protocol" => 'git', # 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. 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 "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", "kde-languages" => "", "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_view => ksb::StatusView->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 markModulePhaseFailed { my ($self, $phase, $module) = @_; assert_isa($module, 'ksb::Module'); $self->{errors}->{$module->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 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; eval { $persistent_options = decode_json($persistent_data); }; if ($@) { # Apparently wasn't JSON, try falling back to old format for compat. # Previously, this was a Perl code which, when evaluated would give # us a hash called persistent_options which we can then merge into our # persistent options. # TODO: Remove compat code after 2018-06-30 eval $persistent_data; # Runs Perl code read from file if ($@) { # Failed. error ("Failed to read persistent module data: r[b[$@]"); return; } } # 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(), '>'); my $json = JSON::PP->new->ascii->pretty; if (!$fh) { error ("Unable to save persistent module data: b[r[$!]"); return; } my $encodedJSON = $json->encode($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}; } sub statusViewer { my $self = shift; return $self->{status_view}; } 1; diff --git a/modules/ksb/BuildException.pm b/modules/ksb/BuildException.pm index f55dd9a..be4d6ff 100644 --- a/modules/ksb/BuildException.pm +++ b/modules/ksb/BuildException.pm @@ -1,100 +1,153 @@ package ksb::BuildException 0.20; # A class to wrap 'exception' messages for the script, allowing them to be # dispatch based on type and automatically stringified. use 5.014; # Needed for state keyword use strict; use warnings; +use Carp; use overload '""' => \&to_string; +use Exporter qw(import); +our @EXPORT = qw(croak_runtime croak_internal had_an_exception make_exception); + sub new { my ($class, $type, $msg) = @_; return bless({ 'exception_type' => $type, 'message' => $msg, }, $class); } sub to_string { my $exception = shift; return $exception->{exception_type} . " Error: " . $exception->{message}; } sub message { my $self = shift; return $self->{message}; } sub setMessage { my ($self, $newMessage) = @_; $self->{message} = $newMessage; } +# +# Exported utility functions +# + +# Returns a Perl exception object to pass to 'die' function +# The returned reference will be an instance of ksb::BuildException. +# +# First parameter: Exception type, 'Exception' if undef +# Second parameter: Message to show to user +sub make_exception +{ + my $exception_type = shift // 'Exception'; + my $message = shift; + my $levels = shift // 0; # Allow for more levels to be removed from bt + + # Remove this subroutine from the backtrace + local $Carp::CarpLevel = 1 + $levels; + + $message = Carp::cluck($message) if $exception_type eq 'Internal'; + return ksb::BuildException->new($exception_type, $message); +} + +# Helper function to return $@ if $@ is a ksb::BuildException. +# +# This function assumes that an eval block had just been used in order to set +# or clear $@ as appropriate. +sub had_an_exception +{ + if ($@ && ref $@ && $@->isa('ksb::BuildException')) { + return $@; + } + + return; +} + +# Should be used for "runtime errors" (i.e. unrecoverable runtime problems that +# don't indicate a bug in the program itself). +sub croak_runtime +{ + die (make_exception('Runtime', $_[0], 1)); +} + +# Should be used for "logic errors" (i.e. impossibilities in program state, things +# that shouldn't be possible no matter what input is fed at runtime) +sub croak_internal +{ + die (make_exception('Internal', $_[0], 1)); +} + # # A small subclass to hold the option name that caused a config exception to # be thrown. # # Typically this will be caught by config-reading code in ksb::Application, # which will add filename and line number information to the message. # package ksb::BuildException::Config 0.10 { use parent qw(ksb::BuildException); use Scalar::Util qw(blessed); sub new { my ($class, $bad_option_name, $msg) = @_; my $self = ksb::BuildException->new('Config', $msg); $self->{'config_invalid_option_name'} = $bad_option_name; return $self; } sub problematicOptionName { my $self = shift; return $self->{'config_invalid_option_name'}; } # Should return a lengthy explanation of how to use a given option for use in # error messages, or undef if no explanation is unavailable. sub optionUsageExplanation { my $optionName = shift; my $result; if (blessed($optionName)) { # Should only happen if called as method: ie. $optionName == $self $optionName = $optionName->problematicOptionName(); } if ($optionName eq 'git-repository-base') { $result = <<"EOF"; The y[git-repository-base] option requires a repository name and URL. e.g. git-repository base y[b[kde] g[b[https://anongit.kde.org/] Use this in a "module-set" group: e.g. module-set kdesupport-set repository y[b[kde] use-modules automoc akonadi soprano attica end module-set EOF } return $result; } 1; }; 1; diff --git a/modules/ksb/BuildSystem.pm b/modules/ksb/BuildSystem.pm index 87988e8..2053f3b 100644 --- a/modules/ksb/BuildSystem.pm +++ b/modules/ksb/BuildSystem.pm @@ -1,500 +1,501 @@ package ksb::BuildSystem 0.30; # Base module for the various build systems, includes built-in implementations of # generic functions and supports hooks for subclasses to provide needed detailed # functionality. use strict; use warnings; use 5.014; +use ksb::BuildException; use ksb::Debug; use ksb::Util; use ksb::StatusView; use List::Util qw(first); sub new { my ($class, $module) = @_; my $self = bless { module => $module }, $class; # This is simply the 'default' build system at this point, also used for # KF5. if ($class ne 'ksb::BuildSystem::KDE4') { _maskGlobalBuildSystemOptions($self); } return $self; } # Removes or masks global build system-related options, so that they aren't # accidentally picked up for use with our non-default build system. # Module-specific options are left intact. sub _maskGlobalBuildSystemOptions { my $self = shift; my $module = $self->module(); my $ctx = $module->buildContext(); my @buildSystemOptions = qw( cmake-options configure-flags custom-build-command cxxflags make-options run-tests use-clean-install ); for my $opt (@buildSystemOptions) { # If an option is present, and not set at module-level, it must be # global. Can't use getOption() method due to recursion. if ($ctx->{options}->{$opt} && !$module->{options}->{$opt}) { $module->{options}->{$opt} = ''; } } } sub module { my $self = shift; return $self->{module}; } # Subroutine to determine if a given module needs to have the build system # recreated from scratch. # If so, it returns a non empty string sub needsRefreshed { my $self = assert_isa(shift, 'ksb::BuildSystem'); my $module = $self->module(); my $builddir = $module->fullpath('build'); my $confFileKey = $self->configuredModuleFileName(); if (not -e "$builddir") { return "the build directory doesn't exist"; } if (-e "$builddir/.refresh-me") { return "the last configure failed"; # see Module.pm } if ($module->getOption("refresh-build")) { return "the option refresh-build was set"; } if (($module->getPersistentOption('failure-count') // 0) > 1) { return "the module has failed to build " . $module->getPersistentOption('failure-count') . " times in a row"; } if (not -e "$builddir/$confFileKey") { return "$builddir/$confFileKey is missing"; } return ""; } # Returns true if the given subdirectory (reference from the module's root source directory) # can be built or not. Should be reimplemented by subclasses as appropriate. sub isSubdirBuildable { return 1; } # Called by the module being built before it runs its build/install process. Should # setup any needed environment variables, build context settings, etc., in preparation # for the build and install phases. sub prepareModuleBuildEnvironment { my ($self, $ctx, $module, $prefix) = @_; } # Returns true if the module should have make install run in order to be # used, or false if installation is not required or possible. sub needsInstalled { return 1; } # This should return a list of executable names that must be present to # even bother attempting to use this build system. An empty list should be # returned if there's no required programs. sub requiredPrograms { return; } sub name { return 'generic'; } # Returns a list of possible build commands to run, any one of which should # be supported by the build system. sub buildCommands { # Non Linux systems can sometimes fail to build when GNU Make would work, # so prefer GNU Make if present, otherwise try regular make. return 'gmake', 'make'; } # Return value style: boolean sub buildInternal { my $self = shift; return $self->safe_make({ target => undef, message => 'Compiling...', 'make-options' => [ split(' ', $self->module()->getOption('make-options')), ], logbase => 'build', subdirs => [ split(' ', $self->module()->getOption("checkout-only")) ], })->{was_successful}; } # Return value style: boolean sub configureInternal { # It is possible to make it here if there's no source dir and if we're # pretending. If we're not actually pretending then this should be a # bug... return 1 if pretending(); croak_internal('We were not supposed to get to this point...'); } # Returns name of file that should exist (relative to the module's build directory) # if the module has been configured. sub configuredModuleFileName { my $self = shift; return 'Makefile'; } # Runs the testsuite for the given module. # Returns true if a testsuite is present and all tests passed, false otherwise. sub runTestsuite { my $self = shift; my $module = $self->module(); info ("\ty[$module] does not support the b[run-tests] option"); return 0; } # Used to install a module (that has already been built, tested, etc.) # All options passed are prefixed to the eventual command to be run. # Returns boolean false if unable to install, true otherwise. sub installInternal { my $self = shift; my $module = $self->module(); my @cmdPrefix = @_; return $self->safe_make ({ target => 'install', message => 'Installing..', 'prefix-options' => [@cmdPrefix], subdirs => [ split(' ', $module->getOption("checkout-only")) ], })->{was_successful}; } # Used to uninstall a previously installed module. # All options passed are prefixed to the eventual command to be run. # Returns boolean false if unable to uninstall, true otherwise. sub uninstallInternal { my $self = shift; my $module = $self->module(); my @cmdPrefix = @_; return $self->safe_make ({ target => 'uninstall', message => "Uninstalling g[$module]", 'prefix-options' => [@cmdPrefix], subdirs => [ split(' ', $module->getOption("checkout-only")) ], })->{was_successful}; } # Subroutine to clean the build system for the given module. Works by # recursively deleting the directory and then recreating it. # Returns 0 for failure, non-zero for success. sub cleanBuildSystem { my $self = assert_isa(shift, 'ksb::BuildSystem'); my $module = $self->module(); my $srcdir = $module->fullpath('source'); my $builddir = $module->fullpath('build'); if (pretending()) { pretend ("\tWould have cleaned build system for g[$module]"); return 1; } # Use an existing directory if (-e $builddir && $builddir ne $srcdir) { info ("\tRemoving files in build directory for g[$module]"); # This variant of log_command runs the sub prune_under_directory($builddir) # in a forked child, so that we can log its output. if (log_command($module, 'clean-builddir', [ 'kdesrc-build', 'main::prune_under_directory', $builddir ])) { error (" r[b[*]\tFailed to clean build directory. Verify the permissions are correct."); return 0; # False for this function. } # Let users know we're done so they don't wonder why rm -rf is taking so # long and oh yeah, why's my HD so active?... info ("\tOld build system cleaned, starting new build system."); } # or create the directory elsif (!super_mkdir ($builddir)) { error ("\tUnable to create directory r[$builddir]."); return 0; } return 1; } sub needsBuilddirHack { return 0; # By default all build systems are assumed to be sane } # Return convention: boolean sub createBuildSystem { my $self = assert_isa(shift, 'ksb::BuildSystem'); my $module = $self->module(); my $builddir = $module->fullpath('build'); my $srcdir = $module->fullpath('source'); if (! -e "$builddir" && !super_mkdir("$builddir")) { error ("\tUnable to create build directory for r[$module]!!"); return 0; } if ($builddir ne $srcdir && $self->needsBuilddirHack() && 0 != log_command($module, 'lndir', ['kdesrc-build', 'main::safe_lndir', $srcdir, $builddir])) { error ("\tUnable to setup symlinked build directory for r[$module]!!"); return 0; } return 1; } # Subroutine to run the build command with the arguments given by the # passed hash. # # In addition to finding the proper executable, this function handles the # step of running the build command for individual subdirectories (as # specified by the checkout-only option to the module). Due to the various # ways the build command is called by this script, it is required to pass # customization options in a hash: # { # target => undef, or a valid build target e.g. 'install', # message => 'Compiling.../Installing.../etc.' # make-options => [ list of command line arguments to pass to make. See # make-options ], # prefix-options => [ list of command line arguments to prefix *before* the # make command, used for make-install-prefix support for # e.g. sudo ], # logbase => 'base-log-filename', # subdirs => [ list of subdirectories of the module to build, # relative to the module's own build directory. ] # } # # target and message are required. logbase is required if target is left # undefined, but otherwise defaults to the same value as target. # # Note that the make command is based on the results of the 'buildCommands' # subroutine which should be overridden if necessary by subclasses. Each # command should be the command name (i.e. no path). The user may override # the command used (for build only) by using the 'custom-build-command' # option. # # The first command name found which resolves to an executable on the # system will be used, if no command this function will fail. # # The first argument should be the ksb::Module object to be made. # The second argument should be the reference to the hash described above. # # Returns a hashref: # { # was_successful => $bool, (if successful) # } sub safe_make (@) { my ($self, $optsRef) = @_; assert_isa($self, 'ksb::BuildSystem'); my $module = $self->module(); # Convert the path to an absolute path since I've encountered a sudo # that is apparently unable to guess. Maybe it's better that it # doesn't guess anyways from a security point-of-view. my $buildCommand = first { absPathToExecutable($_) } $self->buildCommands(); my @buildCommandLine = $buildCommand; # Check for custom user command. We support command line options being # passed to the command as well. my $userCommand = $module->getOption('custom-build-command'); if ($userCommand) { @buildCommandLine = split_quoted_on_whitespace($userCommand); $buildCommand = absPathToExecutable($buildCommandLine[0]); } if (!$buildCommand) { $buildCommand = $userCommand || $self->buildCommands(); error (" r[b[*] Unable to find the g[$buildCommand] executable!"); return { was_successful => 0 }; } # Make it prettier if pretending (Remove leading directories). $buildCommand =~ s{^/.*/}{} if pretending(); shift @buildCommandLine; # $buildCommand is already the first entry. # Simplify code by forcing lists to exist. $optsRef->{'prefix-options'} //= [ ]; $optsRef->{'make-options'} //= [ ]; $optsRef->{'subdirs'} //= [ ]; my @prefixOpts = @{$optsRef->{'prefix-options'}}; # If using sudo ensure that it doesn't wait on tty, but tries to read from # stdin (which should fail as we redirect that from /dev/null) if (@prefixOpts && $prefixOpts[0] eq 'sudo' && !grep { /^-S$/ } @prefixOpts) { splice (@prefixOpts, 1, 0, '-S'); # Add -S right after 'sudo' } # Assemble arguments my @args = (@prefixOpts, $buildCommand, @buildCommandLine); push @args, $optsRef->{target} if $optsRef->{target}; push @args, @{$optsRef->{'make-options'}}; # Will be output by _runBuildCommand my $buildMessage = $optsRef->{message}; # Here we're attempting to ensure that we either run the build command # in each subdirectory, *or* for the whole module, but not both. my @dirs = @{$optsRef->{subdirs}}; push (@dirs, "") if scalar @dirs == 0; for my $subdir (@dirs) { # Some subdirectories shouldn't have the build command run within # them. next unless $self->isSubdirBuildable($subdir); my $logname = $optsRef->{logbase} // $optsRef->{logfile} // $optsRef->{target}; if ($subdir ne '') { $logname = $logname . "-$subdir"; # Remove slashes in favor of something else. $logname =~ tr{/}{-}; # Mention subdirectory that we're working on, move ellipsis # if present. if ($buildMessage =~ /\.\.\.$/) { $buildMessage =~ s/(\.\.\.)?$/ subdirectory g[$subdir]$1/; } } my $builddir = $module->fullpath('build') . "/$subdir"; $builddir =~ s/\/*$//; # Remove trailing / p_chdir ($builddir); return $self->_runBuildCommand($buildMessage, $logname, \@args); }; return { was_successful => 1 }; } # Subroutine to run make and process the build process output in order to # provide completion updates. This procedure takes the same arguments as # log_command() (described here as well), except that the callback argument # is not used. # # First parameter is the message to display to the user while the build # happens. # 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'] # # The return value is a hashref as defined by safe_make sub _runBuildCommand { my ($self, $message, $filename, $argRef) = @_; my $module = $self->module(); my $resultRef = { was_successful => 0 }; my $ctx = $module->buildContext(); # There are situations when we don't want progress output: # 1. If we're not printing to a terminal. # 2. When we're debugging (we'd interfere with debugging output). if (! -t STDERR || debugging()) { note("\t$message"); $resultRef->{was_successful} = (0 == log_command($module, $filename, $argRef)); return $resultRef; } my $time = time; my $statusViewer = $ctx->statusViewer(); $statusViewer->setStatus("\t$message"); $statusViewer->update(); # TODO More details my $warnings = 0; # w00t. Check out the closure! Maks would be so proud. my $log_command_callback = sub { my $input = shift; return if not defined $input; my ($percentage) = ($input =~ /^\[\s*([0-9]+)%]/); if ($percentage) { $statusViewer->setProgressTotal(100); $statusViewer->setProgress($percentage); } else { my ($x, $y) = ($input =~ /^\[([0-9]+)\/([0-9]+)] /); if ($x && $y) { # ninja-syntax $statusViewer->setProgressTotal($y); $statusViewer->setProgress($x); } } $warnings++ if ($input =~ /warning: /); }; $resultRef->{was_successful} = (0 == log_command($module, $filename, $argRef, { callback => $log_command_callback })); $resultRef->{warnings} = $warnings; # Cleanup TTY output. $time = prettify_seconds(time - $time); my $status = $resultRef->{was_successful} ? "g[b[succeeded]" : "r[b[failed]"; $statusViewer->releaseTTY("\t$message $status (after $time)\n"); if ($warnings) { my $count = ($warnings < 3 ) ? 1 : ($warnings < 10 ) ? 2 : ($warnings < 30 ) ? 3 : 4; my $msg = sprintf("%s b[y[$warnings] %s", '-' x $count, '-' x $count); note ("\tNote: $msg compile warnings"); $self->{module}->setPersistentOption('last-compile-warnings', $warnings); } return $resultRef; } 1; diff --git a/modules/ksb/BuildSystem/Autotools.pm b/modules/ksb/BuildSystem/Autotools.pm index ad4f9fb..c2502d2 100644 --- a/modules/ksb/BuildSystem/Autotools.pm +++ b/modules/ksb/BuildSystem/Autotools.pm @@ -1,69 +1,70 @@ package ksb::BuildSystem::Autotools 0.10; # This is a module used to support configuring with autotools. use strict; use warnings; use 5.014; use parent qw(ksb::BuildSystem); +use ksb::BuildException; use ksb::Debug; use ksb::Util; use List::Util qw(first); sub name { return 'autotools'; } # Return value style: boolean sub configureInternal { my $self = assert_isa(shift, 'ksb::BuildSystem::Autotools'); my $module = $self->module(); my $sourcedir = $module->fullpath('source'); my $installdir = $module->installationPath(); # 'module'-limited option grabbing can return undef, so use // # to convert to empty string in that case. my @bootstrapOptions = split_quoted_on_whitespace( $module->getOption('configure-flags', 'module') // ''); my $configureCommand = first { -e "$sourcedir/$_" } qw(configure autogen.sh); my $configureInFile = first { -e "$sourcedir/$_" } qw(configure.in configure.ac); # If we have a configure.in or configure.ac but configureCommand is autogen.sh # we assume that configure is created by autogen.sh as usual in some GNU Projects. # So we run autogen.sh first to create the configure command and # recheck for that. if ($configureInFile && $configureCommand eq 'autogen.sh') { p_chdir($sourcedir); my $err = log_command($module, 'autogen', ["$sourcedir/$configureCommand"]); return 0 if $err != 0; # We don't want a Makefile in the srcdir, so run make-distclean if that happened # ... and hope that is enough to fix it if (-e "$sourcedir/Makefile") { $err = log_command($module, 'distclean', [qw(make distclean)]); return 0 if $err != 0; } # Now recheck $configureCommand = first { -e "$sourcedir/$_" } qw(configure autogen.sh); } croak_internal("No configure command available") unless $configureCommand; p_chdir($module->fullpath('build')); return log_command($module, 'configure', [ "$sourcedir/$configureCommand", "--prefix=$installdir", @bootstrapOptions ]) == 0; } 1; diff --git a/modules/ksb/BuildSystem/QMake.pm b/modules/ksb/BuildSystem/QMake.pm index 53c5626..84fc2a9 100644 --- a/modules/ksb/BuildSystem/QMake.pm +++ b/modules/ksb/BuildSystem/QMake.pm @@ -1,82 +1,83 @@ package ksb::BuildSystem::QMake 0.10; # A build system used to build modules that use qmake use strict; use warnings; use 5.014; use parent qw(ksb::BuildSystem); +use ksb::BuildException; use ksb::Debug; use ksb::Util; use List::Util qw(first); sub name { return 'qmake'; } sub requiredPrograms { return qw{qmake}; } # I've never had problems with modern QMake-using modules being built in a # specific build directory, until I tried using QMake to build Qt5 modules # (past qtbase). Many seem fail with builddir != srcdir sub needsBuilddirHack { my $self = shift; my $module = $self->module(); # Assume code.qt.io modules all need hack for now return ($module->getOption('repository') =~ /qt\.io/); } # Returns the absolute path to 'qmake'. Note the actual executable name may # not necessarily be 'qmake' as some distributions rename it to allow for # co-installability with Qt 3 (and 5...) # If no suitable qmake can be found, undef is returned. # This is a "static class method" i.e. use ksb::BuildSystem::QMake::absPathToQMake() sub absPathToQMake { my @possibilities = qw/qmake qmake4 qmake-qt4 qmake-mac qmake-qt5/; return first { absPathToExecutable($_) } @possibilities; } # Return value style: boolean sub configureInternal { my $self = assert_isa(shift, 'ksb::BuildSystem::QMake'); my $module = $self->module(); my $builddir = $module->fullpath('build'); my $sourcedir = $self->needsBuilddirHack() ? $builddir : $module->fullpath('source'); my @qmakeOpts = split(' ', $module->getOption('qmake-options')); my @projectFiles = glob("$sourcedir/*.pro"); @projectFiles = ("$module.pro") if (!@projectFiles && pretending()); if (!@projectFiles || !$projectFiles[0]) { croak_internal("No *.pro files could be found for $module"); } if (@projectFiles > 1) { error (" b[r[*] Too many possible *.pro files for $module"); return 0; } p_chdir($builddir); my $qmake = absPathToQMake(); return 0 unless $qmake; info ("\tRunning g[qmake]..."); return log_command($module, 'qmake', [ $qmake, @qmakeOpts, $projectFiles[0] ]) == 0; } 1; diff --git a/modules/ksb/DependencyResolver.pm b/modules/ksb/DependencyResolver.pm index 4357c1c..04ad6d6 100644 --- a/modules/ksb/DependencyResolver.pm +++ b/modules/ksb/DependencyResolver.pm @@ -1,519 +1,520 @@ package ksb::DependencyResolver; # Class: DependencyResolver # # This module handles resolving dependencies between modules. Each "module" # from the perspective of this resolver is simply a module full name, as # given by the KDE Project database. (e.g. extragear/utils/kdesrc-build) use strict; use warnings; use 5.014; our $VERSION = '0.20'; +use ksb::BuildException; use ksb::Debug; use ksb::Util; use List::Util qw(first); # Constructor: new # # Constructs a new . # # Parameters: # # moduleFactoryRef - Reference to a sub that creates ksb::Modules from # kde-project module names. Used for ksb::Modules for which the user # requested recursive dependency inclusion. # # Synposis: # # > my $resolver = new DependencyResolver($modNewRef); # > $resolver->readDependencyData(open my $fh, '<', 'file.txt'); # > $resolver->resolveDependencies(@modules); sub new { my $class = shift; my $moduleFactoryRef = shift; my $self = { # hash table mapping short module names (m) to a hashref key by branch # name, the value of which is yet another hashref (see # readDependencyData). Note that this assumes KDE git infrastructure # ensures that all full module names (e.g. # kde/workspace/plasma-workspace) map to a *unique* short name (e.g. # plasma-workspace) by stripping leading path components dependenciesOf => { }, # hash table mapping a wildcarded module name with no branch to a # listref of module:branch dependencies. catchAllDependencies => { }, # reference to a sub that will properly create a ksb::Module from a # given kde-project module name. Used to support automatically adding # dependencies to a build. moduleFactoryRef => $moduleFactoryRef, }; return bless $self, $class; } # Function: shortenModuleName # # Internal: # # This method returns the 'short' module name of kde-project full project paths. # E.g. 'kde/kdelibs/foo' would be shortened to 'foo'. # # This is a static function, not an object method. # # Parameters: # # path - A string holding the full module virtual path # # Returns: # # The module name. sub _shortenModuleName { my $name = shift; $name =~ s{^.*/}{}; # Uses greedy capture by default return $name; } # Method: readDependencyData # # Reads in dependency data in a pseudo-Makefile format. # See kde-build-metadata/dependency-data. # # Parameters: # $self - The DependencyResolver object. # $fh - Filehandle to read dependencies from (should already be open). # # Exceptions: # Can throw an exception on I/O errors or malformed dependencies. sub readDependencyData { my $self = assert_isa(shift, 'ksb::DependencyResolver'); my $fh = shift; my $dependenciesOfRef = $self->{dependenciesOf}; my $dependencyAtom = qr/ ^\s* # Clear leading whitespace ([^\[:\s]+) # (1) Capture anything not a [, :, or whitespace (dependent item) \s* # Clear whitespace we didn't capture (?:\[ # Open a non-capture group... ([^\]:\s]+) # (2) Capture branch name without brackets ])?+ # Close group, make optional, no backtracking \s* # Clear whitespace we didn't capture : \s* ([^\s\[]+) # (3) Capture all non-whitespace (source item) (?:\s*\[ # Open a non-capture group... ([^\]\s]+) # (4) Capture branch name without brackets ])?+ # Close group, make optional, no backtracking \s*$ # Ensure no trailing cruft. Any whitespace should end line /x; # /x Enables extended whitespace mode while(my $line = <$fh>) { # Strip comments, skip empty lines. $line =~ s{#.*$}{}; next if $line =~ /^\s*$/; if ($line !~ $dependencyAtom) { croak_internal("Invalid line $line when reading dependency data."); } my ($dependentItem, $dependentBranch, $sourceItem, $sourceBranch) = $line =~ $dependencyAtom; # Ignore "catch-all" dependencies where the source is the catch-all if ($sourceItem =~ m,\*$,) { warning ("\tIgnoring dependency on wildcard module grouping " . "on line $. of kde-build-metadata/dependency-data"); next; } # Ignore deps on Qt, since we allow system Qt. next if $sourceItem =~ /^\s*Qt/ || $dependentItem =~ /^\s*Qt/; $dependentBranch ||= '*'; # If no branch, apply catch-all flag $sourceBranch ||= '*'; # Source can never be a catch-all so we can shorten early. Also, # we *must* shorten early to avoid a dependency on a long path. $sourceItem = _shortenModuleName($sourceItem); # Handle catch-all dependent groupings if ($dependentItem =~ /\*$/) { $self->{catchAllDependencies}->{$dependentItem} //= [ ]; push @{$self->{catchAllDependencies}->{$dependentItem}}, "$sourceItem:$sourceBranch"; next; } $dependentItem = _shortenModuleName($dependentItem); # Initialize with hashref if not already defined. The hashref will hold # - => [ ] (list of explicit *NON* dependencies of item:$branch), # + => [ ] (list of dependencies of item:$branch) # # Each dependency item is tracked at the module:branch level, and there # is always at least an entry for module:*, where '*' means branch # is unspecified and should only be used to add dependencies, never # take them away. # # Finally, all (non-)dependencies in a list are also of the form # fullname:branch, where "*" is a valid branch. $dependenciesOfRef->{"$dependentItem:*"} //= { '-' => [ ], '+' => [ ], }; # Create actual branch entry if not present $dependenciesOfRef->{"$dependentItem:$dependentBranch"} //= { '-' => [ ], '+' => [ ], }; my $depKey = (index($sourceItem, '-') == 0) ? '-' : '+'; $sourceItem =~ s/^-//; push @{$dependenciesOfRef->{"$dependentItem:$dependentBranch"}->{$depKey}}, "$sourceItem:$sourceBranch"; } } # Function: directDependenciesOf # # Internal: # # Finds and returns the direct dependencies of the given module at a given # branch. This requires forming a list of dependencies for the module from the # "branch neutral" dependencies, adding branch-specific dependencies, and then # removing any explicit non-dependencies for the given branch, which is why # this is a separate routine. # # Parameters: # dependenciesOfRef - hashref to the table of dependencies as read by # . # module - The short name (just the name) of the kde-project module to list # dependencies of. # branch - The branch to assume for module. This must be specified, but use # '*' if you have no specific branch in mind. # # Returns: # A list of dependencies. Every item of the list will be of the form # "$moduleName:$branch", where $moduleName will be the short kde-project module # name (e.g. kdelibs) and $branch will be a specific git branch or '*'. # The order of the entries within the list is not important. sub _directDependenciesOf { my ($dependenciesOfRef, $module, $branch) = @_; my $moduleDepEntryRef = $dependenciesOfRef->{"$module:*"}; my @directDeps; my @exclusions; return unless $moduleDepEntryRef; push @directDeps, @{$moduleDepEntryRef->{'+'}}; push @exclusions, @{$moduleDepEntryRef->{'-'}}; $moduleDepEntryRef = $dependenciesOfRef->{"$module:$branch"}; if ($moduleDepEntryRef && $branch ne '*') { push @directDeps, @{$moduleDepEntryRef->{'+'}}; push @exclusions, @{$moduleDepEntryRef->{'-'}}; } foreach my $exclusion (@exclusions) { # Remove only modules at the exact given branch as a dep. # However catch-alls can remove catch-alls. # But catch-alls cannot remove a specific branch, such exclusions have # to also be specific. @directDeps = grep { $_ ne $exclusion } (@directDeps); } return @directDeps; } # Function: makeCatchAllRules # # Internal: # # Given the internal dependency options data and a kde-project full path, # extracts all "catch-all" rules that apply to the given item and converts # them to standard dependencies for that item. The dependency options are # then appropriately updated. # # No checks are done for logical errors (e.g. having the item depend on # itself) and no provision is made to avoid updating a module that has # already had its catch-all rules generated. # # Parameters: # optionsRef - The hashref as provided to <_visitModuleAndDependencies> # fullName - The kde-project full project path to generate dependencies for. sub _makeCatchAllRules { my ($optionsRef, $fullName) = @_; my $dependenciesOfRef = $optionsRef->{dependenciesOf}; my $item = _shortenModuleName($fullName); while (my ($catchAll, $deps) = each %{$optionsRef->{catchAllDependencies}}) { my $prefix = $catchAll; $prefix =~ s/\*$//; if (($fullName =~ /^$prefix/) || !$prefix) { my $depEntry = "$item:*"; $dependenciesOfRef->{$depEntry} //= { '-' => [ ], '+' => [ ], }; push @{$dependenciesOfRef->{$depEntry}->{'+'}}, @{$deps}; } } } # Function: getBranchOf # # Internal: # # This function extracts the branch of the given Module by calling its # scm object's branch-determining method. It also ensures that the branch # returned was really intended to be a branch (as opposed to a detached HEAD); # undef is returned when the desired commit is not a branch name, otherwise # the user-requested branch name is returned. sub _getBranchOf { my $module = shift; my ($branch, $type) = $module->scm()->_determinePreferredCheckoutSource($module); return ($type eq 'branch' ? $branch : undef); } # Function: visitModuleAndDependencies # # Internal: # # This method is used to topographically sort dependency data. It accepts a # , ensures that any KDE Projects it depends on (which are present # on the build list) are re-ordered before the module, and then adds the # to the build list (whether it is a KDE Project or not, to # preserve ordering). # # See also _visitDependencyItemAndDependencies, which actually does most of # the work of handling dependencies, and calls back to this function when it # finds Modules in the build list. # # Parameters: # optionsRef - hashref to the module dependencies, catch-all dependencies, # module build list, module name to mapping, and auxiliary data # to see if a module has already been visited. # module - The to properly order in the build list. # level - The level of recursion of this call. # dependent - Identical to the same param as _visitDependencyItemAndDependencies # # Returns: # Nothing. The proper build order can be read out from the optionsRef passed # in. sub _visitModuleAndDependencies { my ($optionsRef, $module, $level, $dependentName) = @_; assert_isa($module, 'ksb::Module'); if ($module->scmType() eq 'proj') { my $fullName = $module->fullProjectPath(); my $item = _shortenModuleName($fullName); my $branch = _getBranchOf($module) // '*'; # Since the initial build list is visited start to finish it is # possible for this module to already be in the ordered list if # reordering has already happened or if dependencies are included (i.e. # this was a dependency of some other module). return if ($optionsRef->{visitedItems}->{$item} // 0) == 3; $dependentName //= $item if $module->getOption('include-dependencies'); _visitDependencyItemAndDependencies($optionsRef, $fullName, $branch, $level, $dependentName); $optionsRef->{visitedItems}->{$item} = 3; # Mark as also in build list } $module->setOption('#dependency-level', $level); push @{$optionsRef->{properBuildOrder}}, $module; --($optionsRef->{modulesNeeded}); return; } # Function: visitDependencyItemAndDependencies # # Internal: # # This method is used by _visitModuleAndDependencies to account for dependencies # by kde-project modules across dependency items that are not actually present # in the build. # # For instance, if kde/foo/a depends on kde/lib/bar, and kde/lib/bar depends on # kde/foo/baz, then /a also depends on /baz and should be ordered after /baz. # This function accounts for that in cases such as trying to build only /a and # /baz. # # Parameters: # optionsRef - hashref to the module dependencies, catch-all dependencies, # module build list, module name to mapping, and auxiliary data # to see if a module has already been visited. # dependencyFullItem - a string containing the full kde-projects path for the # the module. The full path is needed to handle wildcarded dependencies. # branch - The specific branch name for the dependency if # needed. The branch name is '*' if the branch doesn't matter (or can be # determined only by the branch-group in use). E.g. '*' or 'master'. # level - Level of recursion of the current call. # dependent - *if set*, is the name of the module that requires that all of its # dependencies be added to the build list (properly ordered) even if not # specifically selected in the configuration file or command line. If not set, # recursive dependencies are not pulled into the build even if they are not # in the build list. # # Returns: # Nothing. The proper build order can be read out from the optionsRef passed # in. Note that the generated build list might be longer than the build list that # was input, in the case that recursive dependency inclusion was requested. sub _visitDependencyItemAndDependencies { my ($optionsRef, $dependencyFullItem, $branch, $level, $dependentName) = @_; my $visitedItemsRef = $optionsRef->{visitedItems}; my $properBuildOrderRef = $optionsRef->{properBuildOrder}; my $dependenciesOfRef = $optionsRef->{dependenciesOf}; my $modulesFromNameRef = $optionsRef->{modulesFromName}; my $moduleFactoryRef = $optionsRef->{moduleFactoryRef}; $level //= 0; my $item = _shortenModuleName($dependencyFullItem); debug ("dep-resolv: Visiting ", (' ' x $level), "$item"); $visitedItemsRef->{$item} //= 0; # This module may have already been added to build. # 0 == Not visited # 1 == Currently visiting. Running into a module in visit state 1 indicates a cycle. # 2 == Visited, but not in build (this may happen for common dependencies with siblings, or for # modules that are not in our build list but are part of dependency chain for other modules # that *are* in build list). # 3 == Visited, placed in build queue. return if $visitedItemsRef->{$item} >= 2; # But if the value is 2 that means we've detected a cycle. if ($visitedItemsRef->{$item} == 1) { croak_internal("Somehow there is a dependency cycle involving $item! :("); } $visitedItemsRef->{$item} = 1; # Mark as currently-visiting for cycle detection. _makeCatchAllRules($optionsRef, $dependencyFullItem); for my $subItem (_directDependenciesOf($dependenciesOfRef, $item, $branch)) { my ($subItemName, $subItemBranch) = ($subItem =~ m/^([^:]+):(.*)$/); croak_internal("Invalid dependency item: $subItem") if !$subItemName; next if $subItemName eq $item; # Catch-all deps might make this happen # This keeps us from doing a deep recursive search for dependencies # on an item we've already asked about. next if (($visitedItemsRef->{$subItemName} // 0) >= 2); debug ("\tdep-resolv: $item:$branch depends on $subItem"); my $subModule = $modulesFromNameRef->{$subItemName}; if (!$subModule && $dependentName) { # Dependent item not in the build, but we're including dependencies $subModule = $moduleFactoryRef->($subItemName); # May not exist, e.g. misspellings or 'virtual' dependencies like # kf5umbrella. But if it does, update the admin for our visit. if ($subModule) { $modulesFromNameRef->{$subModule->name()} = $subModule; ++($optionsRef->{modulesNeeded}); } } if (!$subModule) { debug (" y[b[*] $item depends on $subItem, but no module builds $subItem for this run."); _visitDependencyItemAndDependencies($optionsRef, $subItemName, $subItemBranch, $level + 1, $dependentName); } else { if ($subItemBranch ne '*' && (_getBranchOf($subModule) // '') ne $subItemBranch) { my $wrongBranch = _getBranchOf($subModule) // '?'; error (" r[b[*] $item needs $subItem, not $subItemName:$wrongBranch"); } _visitModuleAndDependencies($optionsRef, $subModule, $level + 1, $dependentName); } last if $optionsRef->{modulesNeeded} == 0; } # Mark as done visiting. $visitedItemsRef->{$item} = 2; return; } # Function: resolveDependencies # # This method takes a list of Modules (real objects, not just # module names). # # These modules have their dependencies resolved, and a new list of # is returned, containing the proper build order for the module given. # # Only "KDE Project" modules can be re-ordered or otherwise affect the # build so this currently won't affect Subversion modules or "plain Git" # modules. # # The dependency data must have been read in first (). # # Parameters: # # $self - The DependencyResolver object. # @modules - List of to evaluate, in suggested build order. # # Returns: # # Modules to build, with the included KDE Project modules in a valid ordering # based on the currently-read dependency data. KDE Project modules are only # re-ordered amongst themselves, other module types retain their relative # positions. sub resolveDependencies { my $self = assert_isa(shift, 'ksb::DependencyResolver'); my @modules = @_; my $optionsRef = { visitedItems => { }, properBuildOrder => [ ], dependenciesOf => $self->{dependenciesOf}, catchAllDependencies => $self->{catchAllDependencies}, # will map names back to their Modules modulesFromName => { map { $_->name() => $_ } grep { $_->scmType() eq 'proj' } @modules }, moduleFactoryRef => $self->{moduleFactoryRef}, # Help _visitModuleAndDependencies to optimize modulesNeeded => scalar @modules, }; for my $module (@modules) { _visitModuleAndDependencies($optionsRef, $module); } return @{$optionsRef->{properBuildOrder}}; } 1; diff --git a/modules/ksb/FirstRun.pm b/modules/ksb/FirstRun.pm index 9f4a971..0c037b5 100644 --- a/modules/ksb/FirstRun.pm +++ b/modules/ksb/FirstRun.pm @@ -1,189 +1,192 @@ package ksb::FirstRun 0.10; use 5.014; use strict; use warnings; use File::Spec qw(splitpath); +use ksb::BuildException; use ksb::Debug qw(colorize); -use ksb::Util; use ksb::OSSupport; =head1 NAME ksb::FirstRun =head1 DESCRIPTION Performs initial-install setup, implementing the C<--initial-setup> option. +B This module is supposed to be loadable even under minimal Perl +environments as fielded in "minimal Docker container" forms of popular distros. + =head1 SYNOPSIS my $exitcode = ksb::FirstRun::setupUserSystem(); exit $exitcode; =cut sub setupUserSystem { my $os = ksb::OSSupport->new; eval { _installSystemPackages($os); _setupBaseConfiguration(); _setupBashrcFile(); }; if (had_an_exception($@)) { my $msg = $@->{message}; say colorize (" b[r[*] r[$msg]"); return 1; } return 0; } # Internal functions # Reads from the __DATA__ section below and dumps the contents in a hash keyed # by filename (the @@ part between each resource). my %packages; sub _readPackages { return \%packages if %packages; my $cur_file; my $cur_value; my $commit = sub { return unless $cur_file; $packages{$cur_file} = ($cur_value =~ s/ *$//r); $cur_value = ''; }; while(my $line = ) { next if $line =~ /^\s*#/; chomp $line; my ($fname) = ($line =~ /^@@ *([^ ]+)$/); if ($fname) { $commit->(); $cur_file = $fname; $cur_value = ''; } else { $cur_value .= "$line "; } } $commit->(); return \%packages; } sub _throw { my $msg = shift; die (make_exception('Setup', $msg)); } sub _installSystemPackages { my $os = shift; my $vendor = $os->vendorID; my $osVersion = $os->vendorVersion; my @packages = _findBestVendorPackageList($os); say colorize(<splitpath($0); _throw("Can't find setup script") unless -e "$baseDir/kdesrc-build-setup" && -x _; my $result = system("$baseDir/kdesrc-build-setup"); _throw("setup script failed: $!") unless ($result >> 8) == 0; } } sub _bashrcIsSetup { return 1; } sub _setupBashrcFile { if (_bashrcIsSetup()) { say colorize(<bestDistroMatch(@supportedDistros); return _packagesForVendor($bestVendor); } sub _packagesForVendor { my $vendor = shift; my $packagesRef = _readPackages(); my @opts = grep { /^pkg\/$vendor\b/ } keys %{$packagesRef}; # TODO Narrow to one set based on distro version my @packages; foreach my $opt (@opts) { @packages = split(' ', $packagesRef->{$opt}); } return @packages; } 1; __DATA__ @@ pkg/debian/unknown shared-mime-info @@ pkg/opensuse/tumbleweed shared-mime-info @@ pkg/fedora/unknown git @@ pkg/gentoo/unknown dev-util/cmake dev-lang/perl @@ pkg/arch/unknown perl-json diff --git a/modules/ksb/IPC.pm b/modules/ksb/IPC.pm index a57e8f5..5faee13 100644 --- a/modules/ksb/IPC.pm +++ b/modules/ksb/IPC.pm @@ -1,402 +1,403 @@ package ksb::IPC; # Handles the asynchronous communications needed to perform update and build # processes at the same time. This can be thought of as a partially-abstract # class, really you should use IPC::Null (which is fully synchronous) or # IPC::Pipe, which both fall back to common methods implemented here. use strict; use warnings; use 5.014; no if $] >= 5.018, 'warnings', 'experimental::smartmatch'; our $VERSION = '0.20'; -use ksb::Util; # make_exception, list_has +use ksb::BuildException; # make_exception use ksb::Debug; +use ksb::Util; # list_has # IPC message types use constant { MODULE_SUCCESS => 1, # Used for a successful src checkout MODULE_FAILURE => 2, # Used for a failed src checkout MODULE_SKIPPED => 3, # Used for a skipped src checkout (i.e. build anyways) MODULE_UPTODATE => 4, # Used to skip building a module when had no code updates # One of these messages should be the first message placed on the queue. ALL_SKIPPED => 5, # Used to indicate a skipped update process (i.e. build anyways) ALL_FAILURE => 6, # Used to indicate a major update failure (don't build) ALL_UPDATING => 7, # Informational message, feel free to start the build. # Used to indicate specifically that a source conflict has occurred. MODULE_CONFLICT => 8, MODULE_LOGMSG => 9, # Tagged message should be put to TTY for module. MODULE_PERSIST_OPT => 10, # Change to a persistent module option ALL_DONE => 11, # Affirmatively flags that all updates are done }; sub new { my $class = shift; my $defaultOpts = { no_update => 0, updated => { }, logged_module => 'global', messages => { }, # Holds log output from update process updates_done => 0, opt_update_handler => undef, # Callback for persistent option changes }; # Must bless a hash ref since subclasses expect it. return bless $defaultOpts, $class; } # Sends a message to the main/build process that a persistent option for the # given module name must be changed. For use by processes that do not control # the persistent option store upon shutdown. sub notifyPersistentOptionChange { my $self = shift; my ($moduleName, $optName, $optValue) = @_; $self->sendIPCMessage(ksb::IPC::MODULE_PERSIST_OPT, "$moduleName,$optName,$optValue"); } sub notifyUpdateSuccess { my $self = shift; my ($module, $msg) = @_; $self->sendIPCMessage(ksb::IPC::MODULE_SUCCESS, "$module,$msg"); } # Sets which module messages stored by sendLogMessage are supposed to be # associated with. sub setLoggedModule { my ($self, $moduleName) = @_; $self->{logged_module} = $moduleName; } # Sends a message to be logged by the process holding the TTY. # The logged message is associated with the module set by setLoggedModule. sub sendLogMessage { my ($self, $msg) = @_; my $loggedModule = $self->{logged_module}; $self->sendIPCMessage(MODULE_LOGMSG, "$loggedModule,$msg"); } # Prints the given message out (adjusting to have proper whitespace # if needed). For use with the log-message forwarding facility. sub _printLoggedMessage { my $msg = shift; $msg = "\t$msg" unless $msg =~ /^\s+/; ksb::Debug::print_clr($msg); } sub _updateSeenModulesFromMessage { my ($self, $ipcType, $buffer) = @_; my $updated = $self->{'updated'}; my $messagesRef = $self->{'messages'}; my $message; croak_runtime("IPC failure: no IPC mechanism defined") unless $ipcType; given ($ipcType) { when (ksb::IPC::MODULE_SUCCESS) { my ($ipcModuleName, $msg) = split(/,/, $buffer); $message = $msg; $updated->{$ipcModuleName} = 'success'; } when (ksb::IPC::MODULE_SKIPPED) { # The difference between success here and 'skipped' below # is that success means we should build even though we # didn't perform an update, while 'skipped' means the # *build* should be skipped even though there was no # failure. $message = 'skipped'; $updated->{$buffer} = 'success'; } when (ksb::IPC::MODULE_CONFLICT) { $message = 'conflicts present'; $updated->{$buffer} = 'failed'; } when (ksb::IPC::MODULE_FAILURE) { $message = 'update failed'; $updated->{$buffer} = 'failed'; } when (ksb::IPC::MODULE_UPTODATE) { # Although the module source hasn't changed, the user might be forcing a # rebuild, so our message should reflect what's actually going to happen. $message = 'no files affected'; my ($ipcModuleName, $refreshReason) = split(',', $buffer); if ($refreshReason) { $updated->{$ipcModuleName} = 'success'; note ("\tNo source update, but $refreshReason"); } else { $updated->{$ipcModuleName} = 'skipped'; } } when (ksb::IPC::MODULE_PERSIST_OPT) { my ($ipcModuleName, $optName, $value) = split(',', $buffer); if ($self->{opt_update_handler}) { # Call into callback to update persistent options $self->{opt_update_handler}->($optName, $optName); } } when (ksb::IPC::MODULE_LOGMSG) { my ($ipcModuleName, $logMessage) = split(',', $buffer, 2); # Save it for later if we can't print it yet. $messagesRef->{$ipcModuleName} //= [ ]; push @{$messagesRef->{$ipcModuleName}}, $logMessage; } when (ksb::IPC::ALL_DONE) { $self->{updates_done} = 1; } default { croak_internal("Unhandled IPC type: $ipcType"); } }; return $message; } # Used to assign a callback / subroutine to use for updating persistent # options based on IPC update messages. The sub should itself take a # key and value pair. sub setPersistentOptionHandler { my ($self, $handler) = @_; $self->{opt_update_handler} = $handler; } sub waitForEnd { my ($self, $module) = @_; $self->waitForStreamStart(); while(!$self->{no_update} && !$self->{updates_done}) { my $buffer; my $ipcType = $self->receiveIPCMessage(\$buffer); # We ignore the return value in favor of ->{updates_done} $self->_updateSeenModulesFromMessage($ipcType, $buffer); } } # Waits for an update for a module with the given name. # Returns a list containing whether the module was successfully updated, # and any specific string message (e.g. for module update success you get # number of files affected) # Will throw an exception for an IPC failure or if the module should not be # built. sub waitForModule { my ($self, $module) = @_; my $moduleName = $module->name(); my $updated = $self->{'updated'}; # Wait for for the initial phase to complete, if it hasn't. $self->waitForStreamStart(); # No update? Just mark as successful if ($self->{'no_update'} || !$module->phases()->has('update')) { $updated->{$moduleName} = 'success'; return ('success', 'Skipped'); } my $message; while(! defined $updated->{$moduleName} && !$self->{updates_done}) { my $buffer; my $ipcType = $self->receiveIPCMessage(\$buffer); $message = $self->_updateSeenModulesFromMessage($ipcType, $buffer); } # If we have 'global' messages they are probably for the first module and # include standard setup messages, etc. Print first and then print module's # messages. my $messagesRef = $self->{'messages'}; for my $item ('global', $moduleName) { for my $msg (@{$messagesRef->{$item}}) { _printLoggedMessage($msg); } delete $messagesRef->{$item}; } return ($updated->{$moduleName}, $message); } # Just in case we somehow have messages to display after all modules are # processed, we have this function to show any available messages near the end # of the script run. sub outputPendingLoggedMessages { my $self = shift; my $messages = $self->{messages}; while (my ($module, $logMessages) = each %{$messages}) { my @nonEmptyMessages = grep { !!$_ } @{$logMessages}; if (@nonEmptyMessages) { debug ("Unhandled messages for module $module:"); ksb::Debug::print_clr($_) foreach @nonEmptyMessages; } } $self->{messages} = { }; } # Flags the given module as something that can be ignored from now on. For use # after the module has been waited on sub forgetModule { my ($self, $module) = @_; my $modulename = $module->name(); delete $self->{'updated'}->{$modulename}; } # Returns a hashref mapping module *names* to update statuses, for modules that # have not already been marked as ignorable using forgetModule() sub unacknowledgedModules { my $self = shift; return $self->{'updated'}; } # Waits on the IPC connection until one of the ALL_* IPC codes is returned. # If ksb::IPC::ALL_SKIPPED is returned then the 'no_update' entry will be set in # $self to flag that you shouldn't wait. # If ksb::IPC::ALL_FAILURE is returned then an exception will be thrown due to the # fatal error. # This method can be called multiple times, but only the first time will # result in a wait. sub waitForStreamStart { my $self = shift; state $waited = 0; return if $waited; my $buffer = ''; my $ipcType = 0; $waited = 1; while ($ipcType != ksb::IPC::ALL_UPDATING) { $ipcType = $self->receiveIPCMessage(\$buffer); if (!$ipcType) { croak_internal("IPC Failure waiting for stream start :( $!"); } if ($ipcType == ksb::IPC::ALL_FAILURE) { croak_runtime("Unable to perform source update for any module:\n\t$buffer"); } elsif ($ipcType == ksb::IPC::ALL_SKIPPED) { $self->{'no_update'} = 1; $self->{'updates_done'} = 1; } elsif ($ipcType == ksb::IPC::MODULE_LOGMSG) { my ($ipcModuleName, $logMessage) = split(',', $buffer); $self->{messages}->{$ipcModuleName} //= [ ]; push @{$self->{messages}->{$ipcModuleName}}, $logMessage; } elsif ($ipcType != ksb::IPC::ALL_UPDATING) { croak_runtime("IPC failure while expecting an update status: Incorrect type: $ipcType"); } } } # Sends an IPC message along with some IPC type information. # # First parameter is the IPC type to send. # Second parameter is the actual message. # All remaining parameters are sent to the object's sendMessage() # procedure. sub sendIPCMessage { my ($self, $ipcType, $msg) = @_; my $encodedMsg = pack("l! a*", $ipcType, $msg); return $self->sendMessage($encodedMsg); } # Static class function to unpack a message. # # First parameter is the message. # Second parameter is a reference to a scalar to store the result in. # # Returns the IPC message type. sub unpackMsg { my ($msg, $outBuffer) = @_; my $returnType; ($returnType, $$outBuffer) = unpack("l! a*", $msg); return $returnType; } # Receives an IPC message and decodes it into the message and its # associated type information. # # First parameter is a *reference* to a scalar to hold the message contents. # All remaining parameters are passed to the underlying receiveMessage() # procedure. # # Returns the IPC type, or undef on failure. sub receiveIPCMessage { my $self = shift; my $outBuffer = shift; croak_internal("Trying to pull message from closed IPC channel!") if $self->{updates_done}; my $msg = $self->receiveMessage(); return ($msg ? unpackMsg($msg, $outBuffer) : undef); } # These must be reimplemented. They must be able to handle scalars without # any extra frills. # # sendMessage should accept one parameter (the message to send) and return # true on success, or false on failure. $! should hold the error information # if false is returned. sub sendMessage { croak_internal("Unimplemented."); } # receiveMessage should return a message received from the other side, or # undef for EOF or error. On error, $! should be set to hold the error # information. sub receiveMessage { croak_internal("Unimplemented."); } # Should be reimplemented if default does not apply. sub supportsConcurrency { return 0; } # Should be reimplemented if default does not apply. sub close { } 1; diff --git a/modules/ksb/IPC/Pipe.pm b/modules/ksb/IPC/Pipe.pm index 12e7fe6..79e8843 100644 --- a/modules/ksb/IPC/Pipe.pm +++ b/modules/ksb/IPC/Pipe.pm @@ -1,126 +1,126 @@ package ksb::IPC::Pipe 0.20; # IPC class that uses pipes in addition to forking for IPC. use strict; use warnings; use 5.014; use parent qw(ksb::IPC); -use ksb::Util qw(croak_internal croak_runtime); +use ksb::BuildException; use IO::Handle; use IO::Pipe; use Errno qw(EINTR); sub new { my $class = shift; my $self = $class->SUPER::new; # Define file handles. $self->{fh} = IO::Pipe->new(); return bless $self, $class; } # Call this to let the object know it will be the update process. sub setSender { my $self = shift; $self->{fh}->writer(); # Disable buffering and any possibility of IO 'interpretation' of the bytes $self->{fh}->autoflush(1); binmode($self->{fh}) } sub setReceiver { my $self = shift; $self->{fh}->reader(); # Disable buffering and any possibility of IO 'interpretation' of the bytes $self->{fh}->autoflush(1); binmode($self->{fh}) } # Reimplementation of ksb::IPC::supportsConcurrency sub supportsConcurrency { return 1; } # Required reimplementation of ksb::IPC::sendMessage # First parameter is the (encoded) message to send. sub sendMessage { my ($self, $msg) = @_; # Since streaming does not provide message boundaries, we will insert # ourselves, by sending a 2-byte unsigned length, then the message. my $encodedMsg = pack ("S a*", length($msg), $msg); my $result = $self->{fh}->syswrite($encodedMsg); if (!$result || length($encodedMsg) != $result) { croak_runtime("Unable to write full msg to pipe: $!"); } return 1; } sub _readNumberOfBytes { my ($self, $length) = @_; my $fh = $self->{fh}; my $readLength = 0; my $result; while ($readLength < $length) { $! = 0; # Reset errno my $curLength = $fh->sysread ($result, ($length - $readLength), $readLength); # EINTR is OK, but check early so we don't trip 0-length check next if (!defined $curLength && $!{EINTR}); return if (defined $curLength && $curLength == 0); croak_internal("Error reading $length bytes from pipe: $!") if !$curLength; croak_internal("sysread read too much: $curLength vs $length") if ($curLength > $length); $readLength += $curLength; } return $result; } # Required reimplementation of ksb::IPC::receiveMessage sub receiveMessage { my $self = shift; # Read unsigned short with msg length, then the message my $msgLength = $self->_readNumberOfBytes(2); return if !$msgLength; $msgLength = unpack ("S", $msgLength); # Decode to Perl type if (!$msgLength) { croak_internal ("Failed to read $msgLength bytes as needed by earlier message!"); } return $self->_readNumberOfBytes($msgLength); } sub close { my $self = shift; $self->{fh}->close(); } 1; diff --git a/modules/ksb/ModuleResolver.pm b/modules/ksb/ModuleResolver.pm index 335a0f3..59ca664 100644 --- a/modules/ksb/ModuleResolver.pm +++ b/modules/ksb/ModuleResolver.pm @@ -1,616 +1,617 @@ package ksb::ModuleResolver 0.20; # Handle proper resolution of module selectors, including option # handling. See POD docs below for more details. use warnings; use 5.014; +use ksb::BuildException; use ksb::Debug; use ksb::Util; use ksb::ModuleSet::KDEProjects; use ksb::Module; use List::Util qw(first); # Public API sub new { my ($class, $ctx) = @_; my $self = { context => $ctx, ignoredSelectors => [ ], # Read in from rc-file inputModulesAndOptions => [ ], cmdlineOptions => { }, deferredOptions => { }, # Holds Modules defined in course of expanding module-sets definedModules => { }, # Holds use-module mentions with their source module-set referencedModules => { }, }; return bless $self, $class; } sub setCmdlineOptions { my ($self, $cmdlineOptionsRef) = @_; $self->{cmdlineOptions} = $cmdlineOptionsRef; return; } sub setDeferredOptions { my ($self, $deferredOptionsRef) = @_; $self->{deferredOptions} = $deferredOptionsRef; return; } sub setIgnoredSelectors { my ($self, $ignoredSelectorsRef) = @_; $self->{ignoredSelectors} = $ignoredSelectorsRef // [ ]; return; } sub setInputModulesAndOptions { my ($self, $modOptsRef) = @_; $self->{inputModulesAndOptions} = $modOptsRef; # Build lookup tables $self->{definedModules} = { map { $_->name() => $_ } (@$modOptsRef) }; $self->{referencedModules} = { _listReferencedModules(@{$modOptsRef}) }; return; } # Applies cmdline and deferred options to the given modules or module-sets. sub _applyOptions { my ($self, @modules) = @_; my $cmdlineOptionsRef = $self->{cmdlineOptions}; my $deferredOptionsRef = $self->{deferredOptions}; foreach my $m (@modules) { my $name = $m->name(); # Apply deferred options first $m->setOption(%{$deferredOptionsRef->{$name} // {}}); $m->getLogDir() if $m->isa('ksb::Module'); # Most of time cmdline options will be empty if (%$cmdlineOptionsRef) { my %moduleCmdlineArgs = ( # order is important here %{$cmdlineOptionsRef->{global} // {}}, %{$cmdlineOptionsRef->{$name} // {}}, ); # Remove any options that would interfere with cmdline args # to avoid any override behaviors in setOption() delete @{$m->{options}}{keys %moduleCmdlineArgs}; # Reapply module-specific cmdline options $m->setOption(%moduleCmdlineArgs); } } return; } # Returns a hash table of all module names referenced in use-module # declarations for any ModuleSets included within the input list. Each entry # in the hash table will map the referenced module name to the source # ModuleSet. sub _listReferencedModules { my %setEntryLookupTable; my @results; for my $moduleSet (grep { $_->isa('ksb::ModuleSet') } (@_)) { @results = $moduleSet->moduleNamesToFind(); # The parens in front of 'x' are semantically required for repetition! @setEntryLookupTable{@results} = ($moduleSet) x scalar @results; } return %setEntryLookupTable; } # Expands out a single module-set listed in referencedModules and places any # ksb::Modules created as a result within the lookup table of Modules. # Returns the list of created ksb::Modules sub _expandSingleModuleSet { my $self = shift; my $neededModuleSet = shift; my $selectedReason = 'partial-expansion:' . $neededModuleSet->name(); my $lookupTableRef = $self->{definedModules}; my $setEntryLookupTableRef = $self->{referencedModules}; # expandModuleSets applies pending/cmdline options already. my @moduleResults = $self->expandModuleSets($neededModuleSet); if (!@moduleResults) { croak_runtime ("$neededModuleSet->name() expanded to an empty list of modules!"); } $_->setOption('#selected-by', $selectedReason) foreach @moduleResults; # Copy entries into the lookup table, especially in case they're # from case 3 @{$lookupTableRef}{map { $_->name() } @moduleResults} = @moduleResults; # Ensure Case 2 and Case 1 stays disjoint (our selectors should now be # in the lookup table if it uniquely matches a module at all). my @moduleSetReferents = grep { $setEntryLookupTableRef->{$_} == $neededModuleSet } (keys %$setEntryLookupTableRef); delete @{$setEntryLookupTableRef}{@moduleSetReferents}; return @moduleResults; } # Determines the most appropriate module to return for a given selector. # The selector may refer to a module or module-set, which means that the # return value may be a list of modules. sub _resolveSingleSelector { my $self = shift; my $selector = shift; my $ctx = $self->{context}; my $selectorName = $selector; my @results; # Will default to '$selector' if unset by end of sub # In the remainder of this code, lookupTableRef is basically handling # case 1, while setEntryLookupTableRef handles case 2. No ksb::Modules # are *both* case 1 and 2 at the same time, and a module-set can only # be case 1. We clean up and handle any case 3s (if any) at the end. my $lookupTableRef = $self->{definedModules}; my $setEntryLookupTableRef = $self->{referencedModules}; # Module selectors beginning with '+' force treatment as a kde-projects # module, which means they won't be matched here (we're only looking for # sets). my $forcedToKDEProject = substr($selectorName, 0, 1) eq '+'; substr($selectorName, 0, 1, '') if $forcedToKDEProject; # Checks cmdline options only my $includingDeps = exists $self->{cmdlineOptions}->{$selectorName}->{'include-dependencies'} || exists $self->{cmdlineOptions}->{'global'}->{'include-dependencies'}; # See resolveSelectorsIntoModules for what the 3 "cases" mentioned below are. # Case 2. We make these checks first since they may update %lookupTable if (exists $setEntryLookupTableRef->{$selectorName} && !exists $lookupTableRef->{$selectorName}) { my $neededModuleSet = $setEntryLookupTableRef->{$selectorName}; my @moduleResults = $self->_expandSingleModuleSet($neededModuleSet); if (!$includingDeps) { $_->setOption('include-dependencies', 0) foreach @moduleResults; } # Now lookupTable should be updated with expanded modules. $selector = $lookupTableRef->{$selectorName} // undef; # If the selector doesn't match a name exactly it probably matches # a wildcard prefix. e.g. 'kdeedu' as a selector would pull in all kdeedu/* # modules, but kdeedu is not a module-name itself anymore. In this # case just return all the modules in the expanded list. if (!$selector) { push @results, @moduleResults; } else { $selector->setOption('#selected-by', 'name'); } } # Case 1 elsif (exists $lookupTableRef->{$selectorName}) { $selector = $lookupTableRef->{$selectorName}; $selector->setOption('#selected-by', 'name') unless $selector->isa('ksb::ModuleSet'); if (!$selector->isa('ksb::ModuleSet') && !$includingDeps) { # modules were manually selected on cmdline, so ignore # module-based include-dependencies, unless # include-dependencies also set on cmdline. $selector->setOption('#include-dependencies', 0); } } elsif (ref $selector && $selector->isa('ksb::Module')) { # We couldn't find anything better than what we were provided, # just use it. $selector->setOption('#selected-by', 'best-guess-after-full-search'); } elsif ($forcedToKDEProject) { # Just assume it's a kde-projects module and expand away... $selector = ksb::ModuleSet::KDEProjects->new($ctx, '_cmdline'); $selector->setModulesToFind($selectorName); $selector->setOption('#include-dependencies', $includingDeps); } else { # Case 3? $selector = ksb::Module->new($ctx, $selectorName); $selector->phases()->phases($ctx->phases()->phases()); if ($selectorName eq 'l10n') { $_->setScmType('l10n') } $selector->setScmType('proj'); $selector->setOption('#guessed-kde-project', 1); $selector->setOption('#selected-by', 'initial-guess'); $selector->setOption('#include-dependencies', $includingDeps); } push @results, $selector unless @results; return @results; } sub _expandAllUnexpandedModuleSets { my $self = shift; my @unexpandedModuleSets = unique_items(values %{$self->{referencedModules}}); $self->_expandSingleModuleSet($_) foreach @unexpandedModuleSets; return; } sub _resolveGuessedModules { my $self = shift; my $ctx = $self->{context}; my @modules = @_; # We didn't necessarily fully expand all module-sets available in the # inputModulesAndOptions when we were resolving selectors. # Because of this we may need to go a step further and expand out all # remaining module-sets in rcFileModulesAndModuleSets if we have 'guess' # modules still left over (since they might be Case 3), and see if we can # then successfully match. if (!first { $_->getOption('#guessed-kde-project', 'module') } @modules) { return @modules; } my $lookupTableRef = $self->{definedModules}; $self->_expandAllUnexpandedModuleSets(); my @results; # We use foreach since we *want* to be able to replace the iterated variable # if we find an existing module. for my $guessedModule (@modules) { if (!$guessedModule->getOption('#guessed-kde-project', 'module')) { push @results, $guessedModule; next; } # If the module we want could be found from within our rc-file # module-sets (even implicitly), use it. Otherwise assume # kde-projects and evaluate now. if (exists $lookupTableRef->{$guessedModule->name()}) { $guessedModule = $lookupTableRef->{$guessedModule->name()}; push @results, $guessedModule; } else { my $set = ksb::ModuleSet::KDEProjects->new($ctx, "guessed_from_cmdline"); $set->setModulesToFind($guessedModule->name()); my @setResults = $self->expandModuleSets($set); my $searchItem = $guessedModule->name(); if (!@setResults) { croak_runtime ("$searchItem doesn't match any modules."); } my $foundModule = first { $_->name() eq $searchItem } @setResults; $guessedModule = $foundModule if $foundModule; push @results, @setResults; } } return @results; } # Resolves already-stored module selectors into ksb::Modules, based on # the options, modules, and module-sets set. # # Returns a list of ksb::Modules in build order, with any module-sets fully # expanded. The desired options will be set for each ksb::Module returned. sub resolveSelectorsIntoModules { my ($self, @selectors) = @_; my $ctx = $self->{context}; # Basically there are 3 types of selectors at this point: # 1. Directly named and defined modules or module-sets. # 2. Referenced (but undefined) modules. These are mentioned in a # use-modules in a module set but not actually available as ksb::Module # objects yet. But we know they will exist. # 3. Indirect modules. These are modules that do exist in the KDE project # metadata, and will be pulled in once all module-sets are expanded # (whether that's due to implicit wildcarding with use-modules, or due # to dependency following). However we don't even know the names for # these yet. # We have to be careful to maintain order of selectors throughout. my @outputList; for my $selector (@selectors) { next if list_has ($self->{ignoredSelectors}, $selector); push @outputList, $self->_resolveSingleSelector($selector); } my @modules = $self->expandModuleSets(@outputList); # If we have any 'guessed' modules then they had no obvious source in the # rc-file. But they might still be implicitly from one of our module-sets # (Case 3). # We want them to use ksb::Modules from the rc-file modules/module-sets # instead of our shell Modules, if possible. @modules = $self->_resolveGuessedModules(@modules); return @modules; } # Similar to resolveSelectorsIntoModules, except that in this case no # 'guessing' for Modules is allowed; the requested module is returned if # present, or undef otherwise. Also unlike resolveSelectorsIntoModules, no # exceptions are thrown if the module is not present. # # The only major side-effect is that all known module-sets are expanded if # necessary before resorting to returning undef. sub resolveModuleIfPresent { my ($self, $moduleName) = @_; if (%{$self->{referencedModules}}) { $self->_expandAllUnexpandedModuleSets(); } # We may not already know about modules that can be found in kde-projects, # so double-check by resolving module name into a kde-projects module-set # selector (the + syntax) and then expanding out the module-set so generated. if (!defined $self->{definedModules}->{$moduleName}) { eval { $self->_expandSingleModuleSet( $self->_resolveSingleSelector("+$moduleName")); }; } return $self->{definedModules}->{$moduleName} // undef; } # Replaces ModuleSets in the given list with their component Modules, and # returns the new list. sub expandModuleSets { my $self = shift; my $ctx = $self->{context}; my @buildModuleList = @_; my @returnList; foreach my $set (@buildModuleList) { my @results = $set; # If a module-set, need to update first so it can then apply its # settings to modules it creates, otherwise update Module directly. $self->_applyOptions($set); if ($set->isa('ksb::ModuleSet')) { @results = $set->convertToModules($ctx); $self->_applyOptions(@results); } push @returnList, @results; } return @returnList; } # Internal API 1; __END__ =head1 ModuleResolver A class that handles general management tasks associated with the module build list, including option handling and resolution of module selectors into actual modules. =head2 METHODS =over =item new Creates a new C. You must pass the appropriate C Don't forget to call setPendingOptions(), setIgnoredSelectors() and setInputModulesAndOptions(). my $resolver = ModuleResolver->new($ctx); =item setPendingOptions Sets the options that should be applied to modules when they are created. No special handling for global options is performed here (but see ksb::OptionsBase::getOption and its friends). You should pass in a hashref, where module-names are keys to values which are themselves hashrefs of option-name => value pairs: $resolver->setPendingOptions( { mod1 => { 'cmake-options' => 'foo', ... }, mod2 => { } }) =item setIgnoredSelectors Declares all selectors that should be ignored by default in the process of expanding module sets. Any modules matching these selectors would be elided from any expanded module sets by default. You should pass a listref of selectors. =item setInputModulesAndOptions Declares the list of all modules and module-sets known to the program, along with their base options. Modules should be ksb::Module objects, module-sets should be ksb::ModuleSet objects, no other types should be present in the list. You should pass a listref of Modules or ModuleSets (as appropriate). =item resolveSelectorsIntoModules Resolves the given list of module selectors into ksb::Module objects, using the pending command-line options, ignore-selectors and available modules/module-sets. Selectors always choose an available ksb::Module or ksb::ModuleSet if present (based on the name() of each Module or ModuleSet, including any use-modules entries for ModuleSet objects). If a selector cannot be directly found then ModuleSet objects may be expanded into their constitutent Module objects and the search performed again. If a selector still cannot be found an exception is thrown. Any embedded ModuleSets are expanded to Modules in the return value. The list of selected Modules is returned, in the approximate order of the input list (selectors for module-sets are expanded in arbitrary order). If you are just looking for a Module that should already be present, see resolveModuleIfPresent(). my @modules = eval { $resolver->resolveSelectorsIntoModules('kdelibs', 'juk'); } =item resolveModuleIfPresent Similar to resolveSelectorsIntoModules(), except that no exceptions are thrown if the module doesn't exist. Only a single module name is supported. =item expandModuleSets Converts any ksb::ModuleSet objects in the given list of Modules and ModuleSets into their component ksb::Module objects (with proper options set, and ignored modules not present). These component objects are spliced into the list of module-type objects, replacing the ModuleSet they came from. The list of ksb::Module objects is then returned. The list passed in is not actually modified in this process. =back =head2 IMPLEMENTATION This module uses a multi-pass option resolving system, in accordance with the way kdesrc-build handles options. Consider a simple kdesrc-buildrc: global cmake-options -DCMAKE_BUILD_TYPE=Debug ... end global module-set ms-foo cmake-options -DCMAKE_BUILD_TYPE=RelWithDebInfo repository kde-projects use-modules kde/kdemultimedia include-dependencies true end module-set options framework1 set-env BUILD_DEBUG 1 end options module taglib repository git://... branch 1.6 end module options juk cxxflags -g3 -Og custom-build-command ninja end options In this case we'd expect that a module like taglib ends up with its C derived from the global section directly, while all modules included from module set C use the C defined in the module-set. At the same time we'd expect that juk has all the options listed in ms-foo, but also the specific C and C options shown, I the juk module had been referenced during the build. There are many ways to convince kdesrc-build to add a module into its build list: =over =item 1. Mention it directly on the command line. =item 2. Include it in the kdesrc-buildrc file, either as a new C block or in a C of a C. =item 3. For KDE modules, mention a component of its project path in a C declaration within a C-based module set. E.g. the "kde/kdemultimedia" entry above, which will pull in the juk module even though "juk" is not named directly. =item 4. For KDE modules, by being a dependency of a module included from a C where the C option is set to C. This wouldn't apply to juk, but might apply to modules such as phonon. Note that "taglib" in this example would B be a dependency of juk according to kdesrc-build (although it is in reality), since taglib is not a KDE module. =back This mission of this class is to ensure that, no matter I a module ended up being selected by the user for the build list, that the same options are registered into the module, the module uses the same build and scm types, is defaulted to the right build phases, etc. To do this, this class takes the read-in options, modules, and module sets from the rc-file, the list of "selectors" requested by the user (via cmdline), any changes to the options from the cmdline, and then takes pains to ensure that any requested modules are returned via the appropriate module-set (and if no module-set can source the module, via default options). In doing so, the class must keep track of module sets, the modules included into each module set, and modules that were mentioned somehow but not already present in the known list of modules (or module sets). Since module sets can cause modules to be defined that are not mentioned anywhere within an rc-file, it may be required to completely expand all module sets in order to verify that a referenced C is B already known. =head2 OUTPUTS From the perspective of calling code, the 'outputs' of this module are lists of C objects, in the order they were selected (or mentioned in the rc-file). See expandModuleSets() and resolveSelectorsIntoModules(). Each object so returned should already have the appropriate options included (based on the cmdlineOptions member, which should be constructed as the union of rc-file and cmdline options). Note that dependency resolution is B handled by this module, see C for that. =cut diff --git a/modules/ksb/ModuleSet/KDEProjects.pm b/modules/ksb/ModuleSet/KDEProjects.pm index 04c1b9e..3a72f23 100644 --- a/modules/ksb/ModuleSet/KDEProjects.pm +++ b/modules/ksb/ModuleSet/KDEProjects.pm @@ -1,226 +1,227 @@ package ksb::ModuleSet::KDEProjects 0.30; # Class: ModuleSet::KDEProjects # # This represents a collective grouping of modules that share common options, # based on the KDE project repositories. Metadata for that repository is # itself housed in a dedicated KDE.org git repository "sysadmin/repo-metadata", # which this class uses to imbue ksb::Modules generated by this ModuleSet. # # The only changes here are to allow for expanding out module specifications # (except for ignored modules), by using KDEProjectsReader. # # See also: ModuleSet use strict; use warnings; use 5.014; use parent qw(ksb::ModuleSet); no if $] >= 5.018, 'warnings', 'experimental::smartmatch'; -use ksb::Module; +use ksb::BuildContext 0.20; +use ksb::BuildException; use ksb::Debug; use ksb::KDEProjectsReader 0.50; -use ksb::BuildContext 0.20; +use ksb::Module; use ksb::Util; sub new { my $self = ksb::ModuleSet::new(@_); $self->{projectsDataReader} = undef; # Will be filled in when we get fh return $self; } # Simple utility subroutine. See List::Util's perldoc sub none_true { ($_ && return 0) for @_; return 1; } sub _createMetadataModule { my ($ctx, $moduleName) = @_; my $metadataModule = ksb::Module->new($ctx, $moduleName =~ s,/,-,r); # Hardcode the results instead of expanding out the project info $metadataModule->setOption('repository', "kde:$moduleName"); $metadataModule->setOption('#xml-full-path', $moduleName); $metadataModule->setOption('#branch:stable', 'master'); $metadataModule->setScmType('metadata'); $metadataModule->setOption('disable-snapshots', 1); $metadataModule->setOption('branch', 'master'); my $moduleSet = ksb::ModuleSet::KDEProjects->new($ctx, ''); $metadataModule->setModuleSet($moduleSet); # Ensure we only ever try to update source, not build. $metadataModule->phases()->phases('update'); return $metadataModule; } # Function: getDependenciesModule # # Static. Returns a that can be used to download the # 'kde-build-metadata' module, which itself contains module dependencies # in the KDE build system. The module is meant to be held by the # # Parameters: # ctx - the for this script execution. sub getDependenciesModule { my $ctx = assert_isa(shift, 'ksb::BuildContext'); return _createMetadataModule($ctx, 'kde-build-metadata'); } # Function: getProjectMetadataModule # # Static. Returns a that can be used to download the # 'repo-metadata' module, which itself contains information on each # repository in the KDE build system (though currently not # dependencies). The module is meant to be held by the # # Parameters: # ctx - the for this script execution. sub getProjectMetadataModule { my $ctx = assert_isa(shift, 'ksb::BuildContext'); return _createMetadataModule($ctx, 'sysadmin/repo-metadata'); } # Function: _expandModuleCandidates # # A class method which goes through the modules in our search list (assumed to # be found in kde-projects), expands them into their equivalent git modules, # and returns the fully expanded list. Non kde-projects modules cause an error, # as do modules that do not exist at all within the database. # # *Note*: Before calling this function, the kde-projects database itself must # have been downloaded first. See getProjectMetadataModule, which ties to the # BuildContext. # # Modules that are part of a module-set requiring a specific branch, that don't # have that branch, are still listed in the return result since there's no way # to tell that the branch won't be there. These should be removed later. # # Parameters: # ctx - The in use. # moduleSearchItem - The search description to expand in ksb::Modules. See # _projectPathMatchesWildcardSearch for a description of the syntax. # # Returns: # @modules - List of expanded git . # # Throws: # Runtime - if the kde-projects database was required but couldn't be # downloaded or read. # Runtime - if the git-desired-protocol is unsupported. # Runtime - if an "assumed" kde-projects module was not actually one. sub _expandModuleCandidates { my $self = assert_isa(shift, 'ksb::ModuleSet::KDEProjects'); my $ctx = assert_isa(shift, 'ksb::BuildContext'); my $moduleSearchItem = shift; my @allModuleResults = $ctx-> getProjectDataReader()-> getModulesForProject($moduleSearchItem); croak_runtime ("Unknown KDE project: $moduleSearchItem") unless @allModuleResults; # It's possible to match modules which are marked as inactive on # projects.kde.org, elide those. my @activeResults = grep { $_->{'active'} } (@allModuleResults); if (!@activeResults) { warning (" y[b[*] Module y[$moduleSearchItem] is apparently a KDE collection, but contains no\n" . "active modules to build!"); my $count = scalar @allModuleResults; if ($count > 0) { warning ("\tAlthough no active modules are available, there were\n" . "\t$count inactive modules. Perhaps the git modules are not ready?"); } } # Setup module options. my @moduleList; my @ignoreList = $self->modulesToIgnore(); foreach (@activeResults) { my $result = $_; my $repo = $result->{'repo'}; # Prefer kde: alias to normal clone URL. $repo =~ s(^git://anongit\.kde\.org/)(kde:); my $newModule = ksb::Module->new($ctx, $result->{'name'}); $self->_initializeNewModule($newModule); $newModule->setOption('repository', $repo); $newModule->setOption('#xml-full-path', $result->{'fullName'}); $newModule->setOption('#branch:stable', undef); $newModule->setOption('#found-by', $result->{found_by}); $newModule->setScmType('proj'); if (none_true( map { ksb::KDEProjectsReader::_projectPathMatchesWildcardSearch( $result->{'fullName'}, $_ ) } (@ignoreList))) { push @moduleList, $newModule; } else { debug ("--- Ignoring matched active module $newModule in module set " . $self->name()); } }; return @moduleList; } # This function should be called after options are read and build metadata is # available in order to convert this module set to a list of ksb::Module. # Any modules ignored by this module set are excluded from the returned list. # The modules returned have not been added to the build context. sub convertToModules { my ($self, $ctx) = @_; my @moduleList; # module names converted to ksb::Module objects. my %foundModules; # Setup default options for each module # Extraction of relevant kde-project modules will be handled immediately # after this phase of execution. for my $moduleItem ($self->modulesToFind()) { # We might have already grabbed the right module recursively. next if exists $foundModules{$moduleItem}; # eval in case the YAML processor throws an exception. undef $@; my @candidateModules = eval { $self->_expandModuleCandidates($ctx, $moduleItem); }; if ($@) { die $@ if had_an_exception(); # Forward exception objects up croak_runtime("The KDE Project database could not be understood: $@"); } my @moduleNames = map { $_->name() } @candidateModules; @foundModules{@moduleNames} = (1) x @moduleNames; push @moduleList, @candidateModules; } if (not scalar @moduleList) { warning ("No modules were defined for the module-set " . $self->name()); warning ("You should use the g[b[use-modules] option to make the module-set useful."); } return @moduleList; } 1; diff --git a/modules/ksb/ModuleSet/Null.pm b/modules/ksb/ModuleSet/Null.pm index edefa4f..c662722 100644 --- a/modules/ksb/ModuleSet/Null.pm +++ b/modules/ksb/ModuleSet/Null.pm @@ -1,32 +1,32 @@ package ksb::ModuleSet::Null 0.10; # Class: ModuleSet::Null # # Used automatically by to represent the abscence of a without # requiring definedness checks. use strict; use warnings; use 5.014; use parent qw(ksb::ModuleSet); -use ksb::Util; +use ksb::BuildException; sub new { my $class = shift; return bless {}, $class; } sub name { return ''; } sub convertToModules { croak_internal("kdesrc-build should not have made it to this call. :-("); } 1; diff --git a/modules/ksb/OSSupport.pm b/modules/ksb/OSSupport.pm index 54abd73..f835ab7 100644 --- a/modules/ksb/OSSupport.pm +++ b/modules/ksb/OSSupport.pm @@ -1,151 +1,157 @@ package ksb::OSSupport 0.10; use 5.014; use strict; use warnings; -use ksb::Util qw(croak_runtime); +use ksb::BuildException qw(croak_runtime); use Text::ParseWords qw(nested_quotewords); use List::Util qw(first); =head1 NAME ksb::OSSupport =head1 DESCRIPTION Provides support code for handling distro-specific functionality, such as lists of package dependencies, command lines to update packages in the first place, and so on. See L for the relevant specification. +B This module is supposed to be loadable even under minimal Perl +environments as fielded in "minimal Docker container" forms of popular distros. + =head1 SYNOPSIS my $os = ksb::OSSupport->new; # Autodetects info on running system say "Current OS is: ", $os->vendorID; =cut =head1 METHODS =head2 new $os = ksb::OSSupport->new; # Manually point to os-release $os = ksb::OSSupport->new('/usr/lib/os-release'); Creates a new object. Required for other methods. =cut sub new { my ($class, $file) = @_; my $self = bless { }, $class; # $file might be undef my @kvListRef = $self->_readOSRelease($file); # Result comes in a listref which itself contains 2-elem # lists... flatten list so it can be assigned to the hash %{$self} = map { @{$_}[0,1] } @kvListRef; return $self; } =head2 vendorID my $vendor = $os->vendorID; # 'gentoo', 'debian', etc. Returns the vendor ID from the I specification. =cut sub vendorID { my $self = shift; return $self->{ID} // 'unknown'; } =head2 vendorVersion my $vendor = $os->vendorVersion; # 'xenial', '17', etc. Returns the vendor Version from the I specification. The first available value from C and then C is used, and 'unknown' is returned if neither are set. =cut sub vendorVersion { my $self = shift; return $self->{VERSION_ID} // $self->{VERSION_CODENAME} // 'unknown'; } =head2 bestDistroMatch # Might return 'fedora' if running on Scientific Linux my $distro = $os->bestDistroMatch(qw/ubuntu fedora arch debian/); This uses the ID (and if needed, ID_LIKE) parameter in /etc/os-release to find the best possible match amongst the provided distro IDs. The list of distros should be ordered with most specific distro first. If no match is found, returns 'linux' (B undef, '', or similar) =cut sub bestDistroMatch { my ($self, @distros) = @_; my @ids = $self->vendorID; if (my $likeDistros = $self->{ID_LIKE} // '') { push @ids, split(' ', $likeDistros); } foreach my $id (@ids) { return $id if first { $id eq $_ } @distros; } return 'linux'; } sub _readOSRelease { my ($self, $fileName) = @_; my @files = $fileName ? $fileName : qw(/etc/os-release /usr/lib/os-release); my ($fh, $error); while (!$fh && @files) { my $file = shift @files; - open $fh, '<:encoding(UTF-8)', $file and last; + + # Can't use PerlIO UTF-8 encoding on minimal distros, which this module + # must be loadable from + open $fh, '<', $file and last; $error = $!; } croak_runtime("Can't open os-release! $error") unless $fh; # skip comments and blank lines, and whitespace-only lines my @lines = grep { ! /^\s*(?:#.*)?\s*$/ } map { chomp; $_ } <$fh>; close $fh; # 0 allows discarding the delimiter and any quotes # Return should be one list per line, hopefully each list has # exactly 2 values ([$key, $value]). return nested_quotewords('=', 0, @lines); } 1; diff --git a/modules/ksb/OptionsBase.pm b/modules/ksb/OptionsBase.pm index e9b0deb..ddb7cc9 100644 --- a/modules/ksb/OptionsBase.pm +++ b/modules/ksb/OptionsBase.pm @@ -1,214 +1,215 @@ package ksb::OptionsBase 0.20; # Common code for dealing with kdesrc-build module options # See POD docs below for more details. use 5.014; use warnings; +use ksb::BuildException; use ksb::Debug; use ksb::Util; use Storable qw(dclone); # Public API sub new { my ($class) = @_; # We don't directly bless the options hash so that subclasses can # use this base hash table directly (as long as they don't overwrite # 'options', of course. my $self = { options => { 'set-env' => { }, # Long story... }, }; return bless $self, $class; } sub hasStickyOption { my ($self, $key) = @_; $key =~ s/^#//; # Remove sticky marker. return 1 if list_has([qw/pretend disable-agent-check/], $key); return exists $self->{options}{"#$key"}; } sub hasOption { my ($self, $key) = @_; return exists $self->{options}{$key}; } # 1. The sticky option overriding the option name given. # 2. The value of the option name given. # 3. The empty string (this function never returns undef directly). # # The first matching option is returned. See ksb::Module::getOption, which # is typically what you should be using. sub getOption { my ($self, $key) = @_; foreach ("#$key", $key) { return $self->{options}{$_} if exists $self->{options}{$_}; } return ''; } # Handles setting set-env options. # # value - Either a hashref (in which case it is simply merged into our # existing options) or a string value of the option as read from the # rc-file (which will have the env-var to set as the first item, the # value for the env-var to take as the rest of the value). sub processSetEnvOption { my ($self, $value) = @_; $self->{options}->{'set-env'} //= { }; my $envVars = $self->{options}->{'set-env'}; if (ref $value) { if (ref $value ne 'HASH') { croak_internal("Somehow passed a non-hashref to set-env handler"); } @{$envVars}{keys %$value} = values %$value; } else { my ($var, $envValue) = split(' ', $value, 2); $envVars->{$var} = $envValue; } return; } # Sets the options in the provided hash to their respective values. If any # special handling is needed then be sure to reimplement this method # and to call this method with the resultant effective set of option-value # pairs. sub setOption { my ($self, %options) = @_; # Special case handling. if (exists $options{'set-env'}) { $self->processSetEnvOption($options{'set-env'}); delete $options{'set-env'}; } # Everything else can be dumped straight into our hash. @{$self->{options}}{keys %options} = values %options; } # Simply removes the given option and its value, if present sub deleteOption { my ($self, $key) = @_; delete $self->{options}{$key} if exists $self->{options}{$key}; } sub mergeOptionsFrom { my $self = shift; my $other = assert_isa(shift, 'ksb::OptionsBase'); my $newOpts = dclone($other->{options}); $self->setOption(%$newOpts); } # Internal API 1; __END__ =head1 OptionsBase A class that encapsulates generic option-handling tasks for kdesrc-build, used to implement common functions within C, C, and C. There is some internal trickery to ensure that program code can override user-selected options in certain situations, which is why we don't simply use a hash table directly. These are the so-called 'sticky' options, seen internally as options with a name starting with #. =head2 METHODS =over =item new Creates a new C. my $self = OptionsBase->new(); =item hasOption Returns true if the given option is present in the collection of options, B>. =item hasStickyOption Returns true if the given option has been overridden by a 'sticky' option. Use C to return the actual value in this case. =item getOption Returns the value of the given option. 'Sticky' options are returned in preference to this object's own option (this allows you to temporarily override an option with a sticky option without overwriting the option value). If no such option is present, returns an empty string. Note that C has its own, much more involved override of this method. Note further that although C is not returned directly by this method, that it's possible for sticky options to be set to undef (if you're setting sticky option values, it's probably best not to do that). =item setOption Sets the given option(s) to the given values. $self->setOption(%options); Normally seen as simply: $self->setOption($option, $value); For the vast majority of possible options, setting the same option again overwrites any previous value. However for C options, additional option sets instead will B to previously-set values. If you need to perform special handling based on option values, subclass this function, but be sure to call B setOption() with the resulting set of options (if any are left to set). =item deleteOption Removes the given option (and its value), if present. =item mergeOptionsFrom Merges options from the given C, replacing any options already present (but keeping other existing options). Nice to quickly setup an options baseline to make small changes afterwards without having to worry about aliasing the other module's option set. =back =head2 INTENT This module is mostly used to encapsulate common code for handling module and module-set options, for use by major subclasses. The code in this class simply gets/sets options. To parse options and determine what options to set, see L and its friends. =cut diff --git a/modules/ksb/RecursiveFH.pm b/modules/ksb/RecursiveFH.pm index 4373e52..a4e6491 100644 --- a/modules/ksb/RecursiveFH.pm +++ b/modules/ksb/RecursiveFH.pm @@ -1,164 +1,165 @@ package ksb::RecursiveFH; use strict; use warnings; use 5.014; our $VERSION = '0.10'; +use ksb::BuildException; use ksb::Util; use File::Basename; # dirname # TODO: Replace make_exception with appropriate croak_* function. sub new { my ($class, $rcfile) = @_; my $data = { 'filehandles' => [], # Stack of filehandles to read 'filenames' => [], # Corresponding tack of filenames (full paths) 'base_path' => [], # Base directory path for relative includes 'current' => undef, # Current filehandle to read 'current_fn' => undef, # Current filename }; my $self = bless($data, $class); $self->pushBasePath(dirname($rcfile)); # rcfile should already be absolute return $self; } # Adds a new filehandle to read config data from. # # This should be called in conjunction with pushBasePath to allow for recursive # includes from different folders to maintain the correct notion of the current # cwd at each recursion level. sub addFile { my ($self, $fh, $fn) = @_; push @{$self->{filehandles}}, $fh; push @{$self->{filenames}}, $fn; $self->setCurrentFile($fh, $fn); } sub popFilehandle { my $self = shift; pop @{$self->{filehandles}}; pop @{$self->{filenames}}; my $newFh = scalar @{$self->{filehandles}} ? ${$self->{filehandles}}[-1] : undef; my $newFilename = scalar @{$self->{filenames}} ? ${$self->{filenames}}[-1] : undef; $self->setCurrentFile($newFh, $newFilename); } sub currentFilehandle { my $self = shift; return $self->{current}; } sub currentFilename { my $self = shift; return $self->{current_fn}; } sub setCurrentFile { my ($self, $fh, $fn) = @_; $self->{current} = $fh; $self->{current_fn} = $fn; } # Sets the base directory to use for any future encountered include entries # that use relative notation, and saves the existing base path (as on a stack). # Use in conjunction with addFile, and use popFilehandle and popBasePath # when done with the filehandle. sub pushBasePath { my $self = shift; push @{$self->{base_path}}, shift; } # See above sub popBasePath { my $self = shift; return pop @{$self->{base_path}}; } # Returns the current base path to use for relative include declarations. sub currentBasePath { my $self = shift; my $curBase = $self->popBasePath(); $self->pushBasePath($curBase); return $curBase; } # Reads the next line of input and returns it. # If a line of the form "include foo" is read, this function automatically # opens the given file and starts reading from it instead. The original # file is not read again until the entire included file has been read. This # works recursively as necessary. # # No further modification is performed to returned lines. # # undef is returned on end-of-file (but only of the initial filehandle, not # included files from there) sub readLine { my $self = shift; # Starts a loop so we can use evil things like "redo" READLINE: { my $line; my $fh = $self->currentFilehandle(); # Sanity check since different methods might try to read same file reader return undef unless defined $fh; if (eof($fh) || !defined($line = <$fh>)) { $self->popFilehandle(); $self->popBasePath(); my $fh = $self->currentFilehandle(); return undef if !defined($fh); redo READLINE; } elsif ($line =~ /^\s*include\s+\S/) { # Include found, extract file name and open file. chomp $line; my ($filename) = ($line =~ /^\s*include\s+(.+?)\s*$/); if (!$filename) { die make_exception('Config', "Unable to handle file include on line $., '$line'"); } my $newFh; my $prefix = $self->currentBasePath(); $filename =~ s/^~\//$ENV{HOME}\//; # Tilde-expand $filename = "$prefix/$filename" unless $filename =~ m(^/); open ($newFh, '<', $filename) or die make_exception('Config', "Unable to open file $filename which was included from line $."); $prefix = dirname($filename); # Recalculate base path $self->addFile($newFh, $filename); $self->pushBasePath($prefix); redo READLINE; } else { return $line; } } } 1; diff --git a/modules/ksb/Updater.pm b/modules/ksb/Updater.pm index 06b7e16..84644cf 100644 --- a/modules/ksb/Updater.pm +++ b/modules/ksb/Updater.pm @@ -1,32 +1,32 @@ package ksb::Updater; # Base class for classes that handle updating the source code for a given ksb::Module. # It should not be used directly. use strict; use warnings; use 5.014; our $VERSION = '0.10'; -use ksb::Util; +use ksb::BuildException; sub new { my ($class, $module) = @_; return bless { module => $module }, $class; } sub name { croak_internal('This package should not be used directly.'); } sub module { my $self = shift; return $self->{module}; } 1; diff --git a/modules/ksb/Updater/Bzr.pm b/modules/ksb/Updater/Bzr.pm index 8fd8f40..ef72fd5 100644 --- a/modules/ksb/Updater/Bzr.pm +++ b/modules/ksb/Updater/Bzr.pm @@ -1,92 +1,93 @@ package ksb::Updater::Bzr 0.10; # Support the bazaar source control manager for libdbusmenu-qt use strict; use warnings; use 5.014; use parent qw(ksb::Updater); +use ksb::BuildException; use ksb::Debug; use ksb::Util; # scm-specific update procedure. # May change the current directory as necessary. # Should return a count of files changed (or commits, or something similar) sub updateInternal { my $self = assert_isa(shift, 'ksb::Updater::Bzr'); my $module = assert_isa($self->module(), 'ksb::Module'); # Full path to source directory on-disk. my $srcdir = $module->fullpath('source'); my $bzrRepoName = $module->getOption('repository'); # Or whatever regex is appropriate to strip the bzr URI protocol. $bzrRepoName =~ s/^bzr:\/\///; if (! -e "$srcdir/.bzr") { # Cmdline assumes bzr will create the $srcdir directory and then # check the source out into that directory. my @cmd = ('bzr', 'branch', $bzrRepoName, $srcdir); # Exceptions are used for failure conditions if (log_command($module, 'bzr-branch', \@cmd) != 0) { die make_exception('Internal', "Unable to checkout $module!"); } # TODO: Filtering the output by passing a subroutine to log_command # should give us the number of revisions, or we can just somehow # count files. my $newRevisionCount = 0; return $newRevisionCount; } else { # Update existing checkout. The source is currently in $srcdir p_chdir($srcdir); if (log_command($module, 'bzr-pull', ['bzr', 'pull']) != 0) { die make_exception('Internal', "Unable to update $module!"); } # I haven't looked at bzr up output yet to determine how to find # number of affected files or number of revisions skipped. my $changeCount = 0; return $changeCount; } return 0; } sub name { return 'bzr'; } # This is used to track things like the last successfully installed # revision of a given module. sub currentRevisionInternal { my $self = assert_isa(shift, 'ksb::Updater::Bzr'); my $module = $self->module(); my $result; # filter_program_output can throw exceptions eval { p_chdir($module->fullpath('source')); ($result, undef) = filter_program_output(undef, 'bzr', 'revno'); chomp $result if $result; }; if ($@) { error ("Unable to run r[b[bzr], is bazaar installed?"); error (" -- Error was: r[$@]"); return undef; } return $result; } 1; diff --git a/modules/ksb/Updater/Git.pm b/modules/ksb/Updater/Git.pm index 36332da..7d8fb67 100644 --- a/modules/ksb/Updater/Git.pm +++ b/modules/ksb/Updater/Git.pm @@ -1,833 +1,834 @@ package ksb::Updater::Git 0.15; # Module which is responsible for updating git-based source code modules. Can # have some features overridden by subclassing (see ksb::Updater::KDEProject # for an example). use strict; use warnings; use 5.014; use parent qw(ksb::Updater); +use ksb::BuildException; use ksb::Debug; use ksb::IPC::Null; use ksb::Util; use File::Basename; # basename use File::Spec; # tmpdir use POSIX qw(strftime); use List::Util qw(first); use IPC::Cmd qw(run_forked); use constant { DEFAULT_GIT_REMOTE => 'origin', }; # scm-specific update procedure. # May change the current directory as necessary. sub updateInternal { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $ipc = shift; $self->{ipc} = $ipc // ksb::IPC::Null->new(); return $self->updateCheckout(); delete $self->{ipc}; } sub name { return 'git'; } sub currentRevisionInternal { my $self = assert_isa(shift, 'ksb::Updater::Git'); return $self->commit_id('HEAD'); } # Returns the current sha1 of the given git "commit-ish". sub commit_id { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $commit = shift or croak_internal("Must specify git-commit to retrieve id for"); my $module = $self->module(); my $gitdir = $module->fullpath('source') . '/.git'; # Note that the --git-dir must come before the git command itself. my ($id, undef) = filter_program_output( undef, # No filter qw/git --git-dir/, $gitdir, 'rev-parse', $commit, ); chomp $id if $id; return $id; } sub _verifyRefPresent { my ($self, $module, $repo) = @_; my ($commitId, $commitType) = $self->_determinePreferredCheckoutSource($module); return 1 if pretending(); my $ref = $commitId; my $hashref = run_forked("git ls-remote --exit-code $repo $ref", { timeout => 10, discard_output => 1, terminate_on_parent_sudden_death => 1}); my $result = $hashref->{exit_code}; return 0 if ($result == 2); # Connection successful, but ref not found return 1 if ($result == 0); # Ref is present croak_runtime("git had error exit $result when verifying $ref present in repository at $repo"); } # Perform a git clone to checkout the latest branch of a given git module # # First parameter is the repository (typically URL) to use. # Throws an exception if it fails. sub _clone { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $git_repo = shift; my $module = $self->module(); my $srcdir = $module->fullpath('source'); my @args = ('--', $git_repo, $srcdir); my $ipc = $self->{ipc} // croak_internal ('Missing IPC object'); note ("Cloning g[$module]"); p_chdir($module->getSourceDir()); my ($commitId, $commitType) = $self->_determinePreferredCheckoutSource($module); $commitId =~ s,^refs/tags/,,; # git-clone -b doesn't like refs/tags/ unshift @args, '-b', $commitId; # Checkout branch right away if (0 != log_command($module, 'git-clone', ['git', 'clone', @args])) { croak_runtime("Failed to make initial clone of $module"); } $ipc->notifyPersistentOptionChange( $module->name(), 'git-cloned-repository', $git_repo); p_chdir($srcdir); # Setup user configuration if (my $name = $module->getOption('git-user')) { my ($username, $email) = ($name =~ /^([^<]+) +<([^>]+)>$/); if (!$username || !$email) { croak_runtime("Invalid username or email for git-user option: $name". " (should be in format 'User Name '"); } whisper ("\tAdding git identity $name for new git module $module"); my $result = (safe_system(qw(git config --local user.name), $username) >> 8) == 0; $result = (safe_system(qw(git config --local user.email), $email) >> 8 == 0) || $result; if (!$result) { warning ("Unable to set user.name and user.email git config for y[b[$module]!"); } } return; } # Either performs the initial checkout or updates the current git checkout # for git-using modules, as appropriate. # # If errors are encountered, an exception is raised. # # Returns the number of *commits* affected. sub updateCheckout { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $module = $self->module(); my $srcdir = $module->fullpath('source'); if (-d "$srcdir/.git") { # Note that this function will throw an exception on failure. return $self->updateExistingClone(); } else { # Check if an existing source directory is there somehow. if (-e "$srcdir" && !is_dir_empty($srcdir)) { if ($module->getOption('#delete-my-patches')) { warning ("\tRemoving conflicting source directory " . "as allowed by --delete-my-patches"); warning ("\tRemoving b[$srcdir]"); safe_rmtree($srcdir) or croak_internal("Unable to delete $srcdir!"); } else { error (<getOption('repository'); if (!$git_repo) { croak_internal("Unable to checkout $module, you must specify a repository to use."); } if (!$self->_verifyRefPresent($module, $git_repo)) { croak_runtime( $self->_moduleIsNeeded() ? "$module build was requested, but it has no source code at the requested git branch" : "The required git branch does not exist at the source repository" ); } $self->_clone($git_repo); return 1 if pretending(); return count_command_output('git', '--git-dir', "$srcdir/.git", 'ls-files'); } return 0; } # Intended to be reimplemented sub _moduleIsNeeded { return 1; } # Selects a git remote for the user's selected repository (preferring a # defined remote if available, using 'origin' otherwise). # # Assumes the current directory is already set to the source directory. # # Throws an exception on error. # # Return value: Remote name that should be used for further updates. # # See also the 'repository' module option. sub _setupBestRemote { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $module = $self->module(); my $cur_repo = $module->getOption('repository'); my $ipc = $self->{ipc} // croak_internal ('Missing IPC object'); # Search for an existing remote name first. If none, add our alias. my @remoteNames = $self->bestRemoteName($cur_repo); if (!@remoteNames) { # The desired repo doesn't have a named remote, this should be # because the user switched it in the rc-file. We control the # 'origin' remote to fix this. if ($self->hasRemote(DEFAULT_GIT_REMOTE)) { if (log_command($module, 'git-update-remote', ['git', 'remote', 'set-url', DEFAULT_GIT_REMOTE, $cur_repo]) != 0) { croak_runtime("Unable to update the fetch URL for existing remote alias for $module"); } } elsif (log_command($module, 'git-remote-setup', ['git', 'remote', 'add', DEFAULT_GIT_REMOTE, $cur_repo]) != 0) { croak_runtime("Unable to add a git remote named " . DEFAULT_GIT_REMOTE . " for $cur_repo"); } push @remoteNames, DEFAULT_GIT_REMOTE; } # Make a notice if the repository we're using has moved. my $old_repo = $module->getPersistentOption('git-cloned-repository'); if ($old_repo and ($cur_repo ne $old_repo)) { note (" y[b[*]\ty[$module]'s selected repository has changed"); note (" y[b[*]\tfrom y[$old_repo]"); note (" y[b[*]\tto b[$cur_repo]"); note (" y[b[*]\tThe git remote named b[", DEFAULT_GIT_REMOTE, "] has been updated"); # Update what we think is the current repository on-disk. $ipc->notifyPersistentOptionChange( $module->name(), 'git-cloned-repository', $cur_repo); } return $remoteNames[0]; } # Completes the steps needed to update a git checkout to be checked-out to # a given remote-tracking branch. Any existing local branch with the given # branch set as upstream will be used if one exists, otherwise one will be # created. The given branch will be rebased into the local branch. # # No checkout is done, this should be performed first. # Assumes we're already in the needed source dir. # Assumes we're in a clean working directory (use git-stash to achieve # if necessary). # # First parameter is the remote to use. # Second parameter is the branch to update to. # Returns boolean success flag. # Exception may be thrown if unable to create a local branch. sub _updateToRemoteHead { my $self = shift; my ($remoteName, $branch) = @_; my $module = $self->module(); # The 'branch' option requests a given head in the user's selected # repository. Normally the remote head is mapped to a local branch, # which can have a different name. So, first we make sure the remote # head is actually available, and if it is we compare its SHA1 with # local branches to find a matching SHA1. Any local branches that are # found must also be remote-tracking. If this is all true we just # re-use that branch, otherwise we create our own remote-tracking # branch. my $branchName = $self->getRemoteBranchName($remoteName, $branch); if (!$branchName) { my $newName = $self->makeBranchname($remoteName, $branch); whisper ("\tUpdating g[$module] with new remote-tracking branch y[$newName]"); if (0 != log_command($module, 'git-checkout-branch', ['git', 'checkout', '-b', $newName, "$remoteName/$branch"])) { croak_runtime("Unable to perform a git checkout of $remoteName/$branch to a local branch of $newName"); } } else { whisper ("\tUpdating g[$module] using existing branch g[$branchName]"); if (0 != log_command($module, 'git-checkout-update', ['git', 'checkout', $branchName])) { croak_runtime("Unable to perform a git checkout to existing branch $branchName"); } # On the right branch, merge in changes. return 0 == log_command($module, 'git-rebase', ['git', 'rebase', "$remoteName/$branch"]); } return 1; } # Completes the steps needed to update a git checkout to be checked-out to # a given commit. The local checkout is left in a detached HEAD state, # even if there is a local branch which happens to be pointed to the # desired commit. Based the given commit is used directly, no rebase/merge # is performed. # # No checkout is done, this should be performed first. # Assumes we're already in the needed source dir. # Assumes we're in a clean working directory (use git-stash to achieve # if necessary). # # First parameter is the commit to update to. This can be in pretty # much any format that git itself will respect (e.g. tag, sha1, etc.). # It is recommended to use refs/$foo/$bar syntax for specificity. # Returns boolean success flag. sub _updateToDetachedHead { my ($self, $commit) = @_; my $module = $self->module(); info ("\tDetaching head to b[$commit]"); return 0 == log_command($module, 'git-checkout-commit', ['git', 'checkout', $commit]); } # Updates an already existing git checkout by running git pull. # # Throws an exception on error. # # Return parameter is the number of affected *commits*. sub updateExistingClone { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $module = $self->module(); my $cur_repo = $module->getOption('repository'); my $result; p_chdir($module->fullpath('source')); # Try to save the user if they are doing a merge or rebase if (-e '.git/MERGE_HEAD' || -e '.git/rebase-merge' || -e '.git/rebase-apply') { croak_runtime ("Aborting git update for $module, you appear to have a rebase or merge in progress!"); } my $remoteName = $self->_setupBestRemote(); # Download updated objects. This also updates remote heads so do this # before we start comparing branches and such. if (0 != log_command($module, 'git-fetch', ['git', 'fetch', '--tags', $remoteName])) { croak_runtime ("Unable to perform git fetch for $remoteName ($cur_repo)"); } # Now we need to figure out if we should update a branch, or simply # checkout a specific tag/SHA1/etc. my ($commitId, $commitType) = $self->_determinePreferredCheckoutSource($module); note ("Updating g[$module] (to $commitType b[$commitId])"); my $start_commit = $self->commit_id('HEAD'); my $updateSub; if ($commitType eq 'branch') { $updateSub = sub { $self->_updateToRemoteHead($remoteName, $commitId) }; } else { $updateSub = sub { $self->_updateToDetachedHead($commitId); } } # With all remote branches fetched, and the checkout of our desired # branch completed, we can now use our update sub to complete the # changes. $self->stashAndUpdate($updateSub); return count_command_output('git', 'rev-list', "$start_commit..HEAD"); } # Goes through all the various combination of git checkout selection options in # various orders of priority. # # Returns a *list* containing: (the resultant symbolic ref/or SHA1,'branch' or # 'tag' (to determine if something like git-pull would be suitable or whether # you have a detached HEAD)). Since the sym-ref is returned first that should # be what you get in a scalar context, if that's all you want. sub _determinePreferredCheckoutSource { my ($self, $module) = @_; $module //= $self->module(); my @priorityOrderedSources = ( # option-name type getOption-inheritance-flag [qw(commit tag module)], [qw(revision tag module)], [qw(tag tag module)], [qw(branch branch module)], [qw(branch-group branch module)], [qw(use-stable-kde branch module)], # commit/rev/tag don't make sense for git as globals [qw(branch branch allow-inherit)], [qw(branch-group branch allow-inherit)], [qw(use-stable-kde branch allow-inherit)], ); # For modules that are not actually a 'proj' module we skip branch-group # and use-stable-kde entirely to allow for global/module branch selection # options to be selected... kind of complicated, but more DWIMy if (!$module->scm()->isa('ksb::Updater::KDEProject')) { @priorityOrderedSources = grep { $_->[0] ne 'branch-group' && $_->[0] ne 'use-stable-kde' } @priorityOrderedSources; } my $checkoutSource; # Sorry about the !!, easiest way to be clear that bool context is intended my $sourceTypeRef = first { !!($checkoutSource = ($module->getOption($_->[0], $_->[2]) // '')) } @priorityOrderedSources; if (!$sourceTypeRef) { return qw(master branch); } # One fixup is needed for use-stable-kde, to pull the actual branch name # from the right spot. Although if no branch name is set we use master, # without trying to search again. if ($sourceTypeRef->[0] eq 'use-stable-kde') { $checkoutSource = $module->getOption('#branch:stable', 'module') || 'master'; } # Likewise branch-group requires special handling. checkoutSource is # currently the branch-group to be resolved. if ($sourceTypeRef->[0] eq 'branch-group') { assert_isa($self, 'ksb::Updater::KDEProject'); $checkoutSource = $self->_resolveBranchGroup($checkoutSource); if (!$checkoutSource) { my $branchGroup = $module->getOption('branch-group'); whisper ("No specific branch set for $module and $branchGroup, using master!"); $checkoutSource = 'master'; } } if ($sourceTypeRef->[0] eq 'tag' && $checkoutSource !~ m{^refs/tags/}) { $checkoutSource = "refs/tags/$checkoutSource"; } return ($checkoutSource, $sourceTypeRef->[1]); } # Splits a URI up into its component parts. Taken from # http://search.cpan.org/~ether/URI-1.67/lib/URI.pm # Copyright Gisle Aas under the following terms: # "This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself." sub _splitUri { my($scheme, $authority, $path, $query, $fragment) = $_[0] =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; return ($scheme, $authority, $path, $query, $fragment); } # This stashes existing changes if necessary, and then runs a provided # update routine in order to advance the given module to the desired head. # Finally, if changes were stashed, they are applied and the stash stack is # popped. # # It is assumed that the required remote has been setup already, that we # are on the right branch, and that we are already in the correct # directory. # # First parameter is a reference to the subroutine to run. This subroutine # should need no parameters and return a boolean success indicator. It may # throw exceptions. # # Throws an exception on error. # # No return value. sub stashAndUpdate { my $self = assert_isa(shift, 'ksb::Updater::Git'); my $updateSub = shift; my $module = $self->module(); my $date = strftime ("%F-%R", gmtime()); # ISO Date, hh:mm time # To find out if we should stash, we just use git diff --quiet, twice to # account for the index and the working dir. # Note: Don't use safe_system, as the error code is stripped to the exit code my $status = pretending() ? 0 : system('git', 'diff', '--quiet'); if ($status == -1 || $status & 127) { croak_runtime("$module doesn't appear to be a git module."); } my $needsStash = 0; if ($status) { # There are local changes. $needsStash = 1; } else { $status = pretending() ? 0 : system('git', 'diff', '--cached', '--quiet'); if ($status == -1 || $status & 127) { croak_runtime("$module doesn't appear to be a git module."); } else { $needsStash = ($status != 0); } } if ($needsStash) { info ("\tLocal changes detected, stashing them away..."); $status = log_command($module, 'git-stash-save', [ qw(git stash save --quiet), "kdesrc-build auto-stash at $date", ]); if ($status != 0) { croak_runtime("Unable to stash local changes for $module, aborting update."); } } if (!$updateSub->()) { error ("\tUnable to update the source code for r[b[$module]"); return; } # Update is performed and successful, re-apply the stashed changes if ($needsStash) { info ("\tModule updated, reapplying your local changes."); $status = log_command($module, 'git-stash-pop', [ qw(git stash pop --index --quiet) ]); if ($status != 0) { error (<module(); my $chosenName; # Use "$branch" directly if not already used, otherwise try to prefix # with the remote name. for my $possibleBranch ($branch, "$remoteName-$branch", "ksdc-$remoteName-$branch") { my $result = system('git', 'show-ref', '--quiet', '--verify', '--', "refs/heads/$possibleBranch") >> 8; return $possibleBranch if $result == 1; } croak_runtime("Unable to find good branch name for $module branch name $branch"); } # Returns the number of lines in the output of the given command. The command # and all required arguments should be passed as a normal list, and the current # directory should already be set as appropriate. # # Return value is the number of lines of output. # Exceptions are raised if the command could not be run. sub count_command_output { # Don't call with $self->, all args are passed to filter_program_output my @args = @_; my $count = 0; filter_program_output(sub { $count++ if $_ }, @args); return $count; } # A simple wrapper that is used to split the output of 'git config --null' # correctly. All parameters are then passed to filter_program_output (so look # there for help on usage). sub slurp_git_config_output { # Don't call with $self->, all args are passed to filter_program_output local $/ = "\000"; # Split on null # This gets rid of the trailing nulls for single-line output. (chomp uses # $/ instead of hardcoding newline chomp(my @output = filter_program_output(undef, @_)); # No filter return @output; } # Returns true if the git module in the current directory has a remote of the # name given by the first parameter. sub hasRemote { my ($self, $remote) = @_; my $hasRemote = 0; eval { filter_program_output(sub { $hasRemote ||= ($_ && /^$remote/) }, 'git', 'remote'); }; return $hasRemote; } # Subroutine to add the 'kde:' alias to the user's git config if it's not # already set. # # Call this as a static class function, not as an object method # (i.e. ksb::Updater::Git::verifyGitConfig, not $foo->verifyGitConfig) # # Returns false on failure of any sort, true otherwise. sub verifyGitConfig { my $configOutput = qx'git config --global --get url.https://anongit.kde.org/.insteadOf kde:'; # 0 means no error, 1 means no such section exists -- which is OK if ((my $errNum = $? >> 8) >= 2) { my $error = "Code $errNum"; my %errors = ( 3 => 'Invalid config file (~/.gitconfig)', 4 => 'Could not write to ~/.gitconfig', 2 => 'No section was provided to git-config', 1 => 'Invalid section or key', 5 => 'Tried to set option that had no (or multiple) values', 6 => 'Invalid regexp with git-config', 128 => 'HOME environment variable is not set (?)', ); $error = $errors{$errNum} if exists $errors{$errNum}; error (" r[*] Unable to run b[git] command:\n\t$error"); return 0; } # If we make it here, I'm just going to assume git works from here on out # on this simple task. if ($configOutput !~ /^kde:\s*$/) { whisper ("\tAdding git download kde: alias"); my $result = safe_system( qw(git config --global --add url.https://anongit.kde.org/.insteadOf kde:) ) >> 8; return 0 if $result != 0; } $configOutput = qx'git config --global --get url.git@git.kde.org:.pushInsteadOf kde:'; if ($configOutput !~ /^kde:\s*$/) { whisper ("\tAdding git upload kde: alias"); my $result = safe_system( qw(git config --global --add url.git@git.kde.org:.pushInsteadOf kde:) ) >> 8; return 0 if $result != 0; } # Remove old kdesrc-build installed aliases (kde: -> git://anongit.kde.org/) $configOutput = qx'git config --global --get url.git://anongit.kde.org/.insteadOf kde:'; if ($configOutput =~ /^kde:\s*$/) { whisper ("\tRemoving outdated kde: alias"); my $result = safe_system( qw(git config --global --unset-all url.git://anongit.kde.org/.insteadOf kde:) ) >> 8; return 0 if $result != 0; } return 1; } 1; diff --git a/modules/ksb/Updater/KDEProjectMetadata.pm b/modules/ksb/Updater/KDEProjectMetadata.pm index ddeb9ad..bcb3c63 100644 --- a/modules/ksb/Updater/KDEProjectMetadata.pm +++ b/modules/ksb/Updater/KDEProjectMetadata.pm @@ -1,69 +1,70 @@ package ksb::Updater::KDEProjectMetadata 0.20; # Updater used only to specifically update the "kde-build-metadata" module # used for storing dependency information, among other things. use strict; use warnings; use 5.014; use parent qw(ksb::Updater::KDEProject); -use ksb::Util; +use ksb::BuildException; use ksb::Debug; +use ksb::Util; use JSON::PP; sub name { return 'metadata'; } # Returns a list of the full kde-project paths for each module to ignore. sub ignoredModules { my $self = assert_isa(shift, 'ksb::Updater::KDEProjectMetadata'); my $path = $self->module()->fullpath('source') . "/build-script-ignore"; # Now that we in theory have up-to-date source code, read in the # ignore file and propagate that information to our context object. my $fh = pretend_open($path) or croak_internal("Unable to read ignore data from $path: $!"); my $ctx = $self->module()->buildContext(); my @ignoreModules = map { chomp $_; $_ } # 3 Remove newlines grep { !/^\s*$/ } # 2 Filter empty lines map { s/#.*$//; $_ } # 1 Remove comments (<$fh>); return @ignoreModules; } # If JSON support is present, and the metadata has already been downloaded # (e.g. with ->updateInternal), returns a hashref to the logical module group # data contained within the kde-build-metadata, decoded from its JSON format. # See https://community.kde.org/Infrastructure/Project_Metadata sub logicalModuleGroups { my $self = shift; my $path = $self->module()->fullpath('source') . "/logical-module-structure"; # The {} is an empty JSON obj to support pretend mode my $fh = pretend_open($path, '{}') or croak_internal("Unable to read logical module structure: $!"); my ($json_hashref, $e) = do { local $/; # The 'local $/' disables line-by-line reading; slurps the whole file undef $@; my $json = eval { decode_json(<$fh>) }; close $fh; ($json, $@); # Implicit return }; croak_runtime ("Unable to load module group data from $path! :(\n\t$e") if $e; return $json_hashref; } 1; diff --git a/modules/ksb/Updater/Svn.pm b/modules/ksb/Updater/Svn.pm index 29230a5..383f470 100644 --- a/modules/ksb/Updater/Svn.pm +++ b/modules/ksb/Updater/Svn.pm @@ -1,672 +1,673 @@ package ksb::Updater::Svn 0.10; # Module responsible for source code updates on Subversion modules. Used as a # superclass for our l10n update/build system as well. use strict; use warnings; use 5.014; use parent qw(ksb::Updater); +use ksb::BuildException; use ksb::Debug; use ksb::Util; use IPC::Open3 qw(open3); # Returns true if a module has a base component to their name (e.g. KDE/, # extragear/, or playground). Note that modules that aren't in trunk/KDE # don't necessary meet this criteria (e.g. kdereview is a module itself). sub _has_base_module { my $moduleName = shift; return $moduleName =~ /^(extragear|playground|KDE)(\/[^\/]+)?$/; } # Subroutine to return the branch prefix. i.e. the part before the branch # name and module name. # # The first parameter is the module name in question. # The second parameter should be 'branches' if we're dealing with a branch # or 'tags' if we're dealing with a tag. # # Ex: 'kdelibs' => 'branches/KDE' # 'kdevelop' => 'branches/kdevelop' sub _branch_prefix { my $moduleName = shift; my $type = shift; # These modules seem to have their own subdir in /tags. my @tag_components = qw/arts koffice amarok kst qt taglib/; # The map call adds the kde prefix to the module names because I don't feel # like typing them all in. my @kde_module_list = ((map {'kde' . $_} qw/-base-artwork -wallpapers accessibility addons admin artwork base bindings edu games graphics libs network pim pimlibs plasma-addons sdk toys utils webdev/)); # If the user already has the module in the form KDE/foo, it's already # done. return "$type/KDE" if $moduleName =~ /^KDE\//; # KDE proper modules seem to use this pattern. return "$type/KDE" if list_has(\@kde_module_list, $moduleName); # KDE extragear / playground modules use this pattern return "$type" if _has_base_module($moduleName); # If we doing a tag just return 'tags' because the next part is the actual # tag name, which is added by the caller, unless the module has its own # subdirectory in /tags. return "$type" if $type eq 'tags' and not list_has(\@tag_components, $moduleName); # Everything else. return "$type/$moduleName"; } # This subroutine is responsible for stripping the KDE/ part from the # beginning of modules that were entered by the user like "KDE/kdelibs" # instead of the normal "kdelibs". That way you can search for kdelibs # without having to strip KDE/ everywhere. sub _moduleBaseName { my $moduleName = shift; $moduleName =~ s/^KDE\///; return $moduleName; } # Subroutine to return a module URL for a module using the 'branch' option. # First parameter is the module in question. # Second parameter is the type ('tags' or 'branches') sub _handle_branch_tag_option { my $module = assert_isa(shift, 'ksb::Module'); my $type = shift; my $branch = _branch_prefix($module->name(), $type); my $svn_server = $module->getOption('svn-server'); my $branchname = $module->getOption($type eq 'branches' ? 'branch' : 'tag'); # Remove trailing slashes. $svn_server =~ s/\/*$//; # Remove KDE/ prefix for module name. my $moduleName = _moduleBaseName($module->name()); # KDE modules have a different module naming scheme than the rest it seems. return "$svn_server/$branch/$branchname/$moduleName" if $branch =~ /\/KDE\/?$/; # Non-trunk translations happen in a single branch. Assume all non-trunk # global branches are intended for the stable translations. if ($moduleName =~ /^l10n-kde4\/?/ && $branch ne 'trunk') { return "$svn_server/branches/stable/$moduleName"; } # Otherwise don't append the module name by default since it makes more # sense to branch this way in many situations (i.e. kdesupport tags, phonon) return "$svn_server/$branch/$branchname"; } # Subroutine to return the appropriate SVN URL for a given module, based on # the user settings. For example, 'kdelibs' -> # https://svn.kde.org/home/kde/trunk/KDE/kdelibs # # This operates under a double hierarchy: # 1. If any module-specific option is present, it wins. # 2. If only global options are present, the order override-url, tag, # branch, module-base-path, is preferred. sub svn_module_url { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my $svn_server = $module->getOption('svn-server'); my $modulePath; foreach my $levelLimit ('module', 'allow-inherit') { $modulePath = $module->getOption('module-base-path', $levelLimit); # Allow user to override normal processing of the module in a few ways, # to make it easier to still be able to use kdesrc-build even when I # can't be there to manually update every little special case. if($module->getOption('override-url', $levelLimit)) { return $module->getOption('override-url', $levelLimit); } if($module->getOption('tag', $levelLimit)) { return _handle_branch_tag_option($module, 'tags'); } my $branch = $module->getOption('branch', $levelLimit); if($branch and $branch ne 'trunk') { return _handle_branch_tag_option($module, 'branches'); } my $moduleName = _moduleBaseName($module->name()); # The following modules are in /trunk, not /trunk/KDE. There are others, # but these are the important ones. my @non_trunk_modules = qw(extragear kdesupport koffice icecream kde-common playground KDE kdereview www l10n-kde4); my $module_root = $moduleName; $module_root =~ s/\/.*//; # Remove everything after the first slash if (not $modulePath and $levelLimit eq 'allow-inherit') { $modulePath = "trunk/KDE/$moduleName"; $modulePath = "trunk/$moduleName" if list_has(\@non_trunk_modules, $module_root); $modulePath =~ s/^\/*//; # Eliminate / at beginning of string. $modulePath =~ s/\/*$//; # Likewise at the end. } last if $modulePath; } # Remove trailing slashes. $svn_server =~ s/\/*$//; # Note that the module name is no longer appended if module-base-path is used (i.e. # $branch variable was set. This is a change as of version 1.8. return "$svn_server/$modulePath"; } # Subroutine to determine whether or not the given module has the correct # URL. If not, a warning is printed out. # First parameter: module to check. # Return: Nothing. sub _verifyCorrectServerURL { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my $module_expected_url = $self->svn_module_url(); my $module_actual_url = $self->svnInfo('URL'); if (!$module_actual_url) { croak_runtime ("Unable to determine working copy's svn URL for $module"); } $module_expected_url =~ s{/+$}{}; # Remove trailing slashes $module_actual_url =~ s{/+$}{}; # Remove trailing slashes if ($module_actual_url ne $module_expected_url) { # Check if the --src-only flag was passed. my $module = $self->module(); if ($module->buildContext()->getOption('#allow-auto-repo-move')) { note ("g[$module] is checked out from a different location than expected."); note ("Attempting to correct to $module_expected_url"); my ($expected_host, $expected_path) = ($module_expected_url =~ m{://([^/]+)/(.*)$}); my ($actual_host, $actual_path) = ($module_actual_url =~ m{://([^/]+)/(.*)$}); # If the path didn't change but the host info did try --relocate # otherwise try regular svn switch. if (($expected_path eq $actual_path) && ($expected_host ne $actual_host)) { log_command($module, 'svn-switch', [ 'svn', 'switch', '--relocate', $module_actual_url, $module_expected_url]); } else { log_command($module, 'svn-switch', [ 'svn', 'switch', $module_expected_url]); } return; } warning (<module(); # svn 1.7 has a different working copy format that must be manually # converted. This will mess up everything else so make this our first # check. p_chdir($module->fullpath('source')); # gensym makes a symbol that can be made a filehandle by open3 use Symbol qw(gensym); # Can't use filter_program_output as that doesn't capture STDERR on # purpose. We, on the other hand, just want STDERR. my $stderrReader = gensym(); my $pid = open3(undef, undef, $stderrReader, 'svn', '--non-interactive', 'status'); my @errorLines = grep { /:\s*E155036:/ } (<$stderrReader>); waitpid ($pid, 0); if (@errorLines) { warning (<_verifyCorrectServerURL(); } # Subroutine used to handle the checkout-only option. It handles updating # subdirectories of an already-checked-out module. # # This function can throw an exception in the event of a update failure. # # First parameter is the module. # All remaining parameters are subdirectories to check out. # # Returns the number of files changed by the update, or undef if unable to # be determined. sub update_module_subdirectories { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my $numChanged = 0; # If we have elements in @path, download them now for my $dir (@_) { info ("\tUpdating g[$dir]"); my $logname = $dir; $logname =~ tr{/}{-}; my $count = $self->run_svn("svn-up-$logname", [ 'svn', 'up', $dir ]); $numChanged = undef unless defined $count; $numChanged += $count if defined $numChanged; } return $numChanged; } # Checkout a module that has not been checked out before, along with any # subdirectories the user desires. # # This function will throw an exception in the event of a failure to update. # # The first parameter is the module to checkout (including extragear and # playground modules). # All remaining parameters are subdirectories of the module to checkout. # # Returns number of files affected, or undef. sub checkout_module_path { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my @path = @_; my %pathinfo = $module->getInstallPathComponents('source'); my @args; if (not -e $pathinfo{'path'} and not super_mkdir($pathinfo{'path'})) { croak_runtime ("Unable to create path r[$pathinfo{path}]!"); } p_chdir ($pathinfo{'path'}); my $svn_url = $self->svn_module_url(); my $modulename = $pathinfo{'module'}; # i.e. kdelibs for KDE/kdelibs as $module push @args, ('svn', 'co', '--non-interactive'); push @args, '-N' if scalar @path; # Tells svn to only update the base dir push @args, $svn_url; push @args, $modulename; note ("Checking out g[$module]"); my $count = $self->run_svn('svn-co', \@args); p_chdir ($pathinfo{'module'}) if scalar @path; my $count2 = $self->update_module_subdirectories(@path); return $count + $count2 if defined $count and defined $count2; return undef; } # Update a module that has already been checked out, along with any # subdirectories the user desires. # # This function will throw an exception in the event of an update failure. # # The first parameter is the module to checkout (including extragear and # playground modules). # All remaining parameters are subdirectories of the module to checkout. sub update_module_path { my ($self, @path) = @_; assert_isa($self, 'ksb::Updater::Svn'); my $module = $self->module(); my $fullpath = $module->fullpath('source'); my @args; p_chdir ($fullpath); push @args, ('svn', 'up', '--non-interactive'); push @args, '-N' if scalar @path; note ("Updating g[$module]"); my $count = eval { $self->run_svn('svn-up', \@args); }; # Update failed, try svn cleanup. if (had_an_exception() && $@->{exception_type} ne 'ConflictPresent') { info ("\tUpdate failed, trying a cleanup."); my $result = safe_system('svn', 'cleanup'); $result == 0 or croak_runtime ("Unable to update $module, " . "svn cleanup failed with exit code $result"); info ("\tCleanup complete."); # Now try again (allow exception to bubble up this time). $count = $self->run_svn('svn-up-2', \@args); } my $count2 = $self->update_module_subdirectories(@path); return $count + $count2 if defined $count and defined $count2; return undef; } # Run the svn command. This is a special subroutine so that we can munge # the generated output to see what files have been added, and adjust the # build according. # # This function will throw an exception in the event of a build failure. # # First parameter is the ksb::Module object we're building. # Second parameter is the filename to use for the log file. # Third parameter is a reference to a list, which is the command ('svn') # and all of its arguments. # Return value is the number of files update (may be undef if unable to tell) sub run_svn { my ($self, $logfilename, $arg_ref) = @_; assert_isa($self, 'ksb::Updater::Svn'); my $module = $self->module(); my $revision = $module->getOption('revision'); if ($revision && $revision ne '0') { my @tmp = @{$arg_ref}; # Insert after first two entries, deleting 0 entries from the # list. splice @tmp, 2, 0, '-r', $revision; $arg_ref = \@tmp; } my $count = 0; my $conflict = 0; my $callback = sub { return unless $_; # The check for capitalized letters in the second column is because # svn can use the first six columns for updates (the characters will # all be uppercase), which makes it hard to tell apart from normal # sentences (like "At Revision foo" $count++ if /^[UPDARGMC][ A-Z]/; $conflict = 1 if /^C[ A-Z]/; }; # Do svn update. my $result = log_command($module, $logfilename, $arg_ref, { callback => $callback }); return 0 if pretending(); croak_runtime("Error updating $module!") unless $result == 0; if ($conflict) { warning ("Source code conflict exists in r[$module], this module will not"); warning ("build until it is resolved."); die make_exception('ConflictPresent', "Source conflicts exist in $module"); } return $count; } # Subroutine to check for subversion conflicts in a module. Basically just # runs svn st and looks for "^C". # # First parameter is the module to check for conflicts on. # Returns 0 if a conflict exists, non-zero otherwise. sub module_has_conflict { my $module = assert_isa(shift, 'ksb::Module'); my $srcdir = $module->fullpath('source'); if ($module->getOption('no-svn')) { whisper ("\tSource code conflict check skipped."); return 1; } else { info ("\tChecking for source conflicts... "); } my $pid = open my $svnProcess, "-|"; if (!$pid) { error ("\tUnable to open check source conflict status: b[r[$!]"); return 0; # false allows the build to proceed anyways. }; if (0 == $pid) { close STDERR; # No broken pipe warnings disable_locale_message_translation(); exec {'svn'} (qw/svn --non-interactive st/, $srcdir) or croak_runtime("Cannot execute 'svn' program: $!"); # Not reached } while (<$svnProcess>) { if (/^C/) { error (<isa('ksb::Module') should be true. sub updateInternal { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my $fullpath = $module->fullpath('source'); my @options = split(' ', $module->getOption('checkout-only')); if (-e "$fullpath/.svn") { $self->check_module_validity(); my $updateCount = $self->update_module_path(@options); my $log_filter = sub { return unless defined $_; print $_ if /^C/; print $_ if /Checking for/; return; }; # Use log_command as the check so that an error file gets created. if (0 != log_command($module, 'conflict-check', ['kdesrc-build', 'ksb::Updater::Svn::module_has_conflict', $module], { callback => $log_filter, no_translate => 1 }) ) { croak_runtime (" * Conflicts present in module $module"); } return $updateCount; } else { return $self->checkout_module_path(@options); } } sub name { return 'svn'; } sub currentRevisionInternal { my $self = assert_isa(shift, 'ksb::Updater::Svn'); return $self->svnInfo('Revision'); } # Returns a requested parameter from 'svn info'. # # First parameter is a string with the name of the parameter to retrieve (e.g. URL). # Each line of output from svn info is searched for the requested string. # Returns the string value of the parameter or undef if an error occurred. sub svnInfo { my $self = assert_isa(shift, 'ksb::Updater::Svn'); my $module = $self->module(); my $param = shift; my $srcdir = $module->fullpath('source'); my $result; # Predeclare to outscope upcoming eval if (pretending() && ! -e $srcdir) { return 'Unknown'; } # Search each line of output, ignore stderr. # eval since filter_program_output uses exceptions. eval { # Need to chdir into the srcdir, in case srcdir is a symlink. # svn info /path/to/symlink barfs otherwise. p_chdir ($srcdir); my @lines = filter_program_output( sub { /^$param:/ }, 'svn', 'info', '--non-interactive', '.' ); croak_runtime ("No svn info output!") unless @lines; chomp ($result = $lines[0]); $result =~ s/^$param:\s*//; }; if($@) { error ("Unable to run r[b[svn], is the Subversion program installed?"); error (" -- Error was: r[$@]"); return undef; } return $result; } 1; diff --git a/modules/ksb/Util.pm b/modules/ksb/Util.pm index ee5f034..5a77947 100644 --- a/modules/ksb/Util.pm +++ b/modules/ksb/Util.pm @@ -1,764 +1,670 @@ -package ksb::Util 0.20; +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 Carp qw(cluck); 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 HTTP::Tiny; 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 - croak_runtime croak_internal had_an_exception make_exception - download_file absPathToExecutable + absPathToExecutable fileDigestMD5 log_command disable_locale_message_translation 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 # current PATH. e.g. if you pass make you could get '/usr/bin/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 = shift; my @paths = split(/:/, $ENV{'PATH'}); # If it starts with a / the path is already absolute. return $prog if $prog =~ /^\//; for my $path (@paths) { return "$path/$prog" if (-x "$path/$prog"); } return undef; } -# Returns a Perl object worth "die"ing for. (i.e. can be given to the die -# function and handled appropriately later with an eval). The returned -# reference will be an instance of ksb::BuildException. The actual exception -# type is passed in as the first parameter (as a string), and can be retrieved -# from the object later using the 'exception_type' key, and the message is -# returned as 'message' -# -# First parameter: Exception type. Recommended are one of: Config, Internal -# (for logic errors), Runtime (other runtime errors which are not logic -# bugs in kdesrc-build), or just leave blank for 'Exception'. -# Second parameter: Message to show to user -# Return: Reference to the exception object suitable for giving to "die" -sub make_exception -{ - my $exception_type = shift // 'Exception'; - my $message = shift; - my $levels = shift // 0; # Allow for more levels to be removed from bt - - # Remove this subroutine from the backtrace - local $Carp::CarpLevel = 1 + $levels; - - $message = Carp::cluck($message) if $exception_type eq 'Internal'; - return ksb::BuildException->new($exception_type, $message); -} - -# Helper function to return $@ if $@ is a ksb::BuildException. -# -# This function assumes that an eval block had just been used in order to set or -# clear $@ as appropriate. -sub had_an_exception -{ - if ($@ && ref $@ && $@->isa('ksb::BuildException')) { - return $@; - } - - return; -} - -# Should be used for "runtime errors" (i.e. unrecoverable runtime problems that -# don't indicate a bug in the program itself). -sub croak_runtime -{ - die (make_exception('Runtime', $_[0], 1)); -} - -# Should be used for "logic errors" (i.e. impossibilities in program state, things -# that shouldn't be possible no matter what input is fed at runtime) -sub croak_internal -{ - die (make_exception('Internal', $_[0], 1)); -} - # 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. sub prettify_seconds { my $elapsed = $_[0]; my $str = ""; my ($days,$hours,$minutes,$seconds,$fraction); $fraction = int (100 * ($elapsed - int $elapsed)); $elapsed = int $elapsed; $seconds = $elapsed % 60; $elapsed = int $elapsed / 60; $minutes = $elapsed % 60; $elapsed = int $elapsed / 60; $hours = $elapsed % 24; $elapsed = int $elapsed / 24; $days = $elapsed; $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; } # 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)); 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 (< "kdesrc-build/$scriptVersion ", - timeout => 30, - ); - - if ($proxy) { - whisper ("Using proxy $proxy for HTTP downloads"); - $opts{proxy} = $proxy; - } - - my $http_client = HTTP::Tiny->new(%opts); - - whisper ("Downloading g[$filename] from g[$url]"); - my $response = $http_client->mirror($url, $filename); - - return 1 if $response->{success}; - - $response->{reason} .= " $response->{content}" if $response->{status} == 599; - error ("Failed to download y[b[$url] to b[$filename]"); - error ("Result was: y[b[$response->{status} $response->{reason}]"); - - return 0; -} - # Function: pretend_open # # Opens the given file and returns a filehandle to it if the file actually # exists or the script is not in pretend mode. If the script is in pretend mode # and the file is not already present then an open filehandle to an empty # string is returned. # # Parameters: # filename - Path to the file to open. # default - String to use if the file doesn't exist in pretend mode # # Returns: # filehandle on success (supports readline() and eof()), can return boolean # false if there is an error opening an existing file (or if the file doesn't # exist when not in pretend mode) sub pretend_open { my $path = shift; my $defaultText = shift // ''; my $fh; if (pretending() && ! -e $path) { open $fh, '<', \$defaultText or return; } else { open $fh, '<', $path or return; } return $fh; } # Returns true if the given sub returns true for any item in the given listref. sub any(&@) { my ($subRef, $listRef) = @_; ($subRef->($_) && 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; } 1;