X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debian%2FDebhelper%2FDh_Lib.pm;h=8af365ffa7509956c1c30a93526cb4dde96162ad;hb=2a9c750718dc42c39b3ccfd52aa271cda038e6d1;hp=d26b7ead75aa29e9d294400cedc4e83b5047dd3a;hpb=487dd17039d4036cc83dfbe866c69802a4a67bdb;p=debhelper.git diff --git a/Debian/Debhelper/Dh_Lib.pm b/Debian/Debhelper/Dh_Lib.pm index d26b7ea..8af365f 100644 --- a/Debian/Debhelper/Dh_Lib.pm +++ b/Debian/Debhelper/Dh_Lib.pm @@ -2,7 +2,7 @@ # # Library functions for debhelper programs, perl version. # -# Joey Hess, GPL copyright 1997-2000. +# Joey Hess, GPL copyright 1997-2008. package Debian::Debhelper::Dh_Lib; use strict; @@ -15,34 +15,25 @@ use vars qw(@ISA @EXPORT %dh); &filedoublearray &getpackages &basename &dirname &xargs %dh &compat &addsubstvar &delsubstvar &excludefile &package_arch &is_udeb &udeb_filename &debhelper_script_subst &escape_shell - &inhibit_log); + &inhibit_log &load_log &write_log &dpkg_architecture_value + &sourcepackage + &is_make_jobserver_unavailable &clean_jobserver_makeflags); my $max_compat=7; sub init { - # If DH_OPTIONS is set, prepend it @ARGV. - if (defined($ENV{DH_OPTIONS})) { - # Ignore leading/trailing whitespace. - $ENV{DH_OPTIONS}=~s/^\s+//; - $ENV{DH_OPTIONS}=~s/\s+$//; - unshift @ARGV,split(/\s+/,$ENV{DH_OPTIONS}); - } + my %params=@_; - # Check to see if an argument on the command line starts with a dash. - # if so, we need to pass this off to the resource intensive + # Check to see if an option line starts with a dash, + # or DH_OPTIONS is set. + # If so, we need to pass this off to the resource intensive # Getopt::Long, which I'd prefer to avoid loading at all if possible. - my $parseopt=undef; - my $arg; - foreach $arg (@ARGV) { - if ($arg=~m/^-/) { - $parseopt=1; - last; - } - } - if ($parseopt) { + if ((defined $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}) || + (defined $ENV{DH_INTERNAL_OPTIONS} && length $ENV{DH_INTERNAL_OPTIONS}) || + grep /^-/, @ARGV) { eval "use Debian::Debhelper::Dh_Getopt"; - error($!) if $@; - %dh=Debian::Debhelper::Dh_Getopt::parseopts(); + error($@) if $@; + Debian::Debhelper::Dh_Getopt::parseopts($params{options}); } # Another way to set excludes. @@ -85,9 +76,6 @@ sub init { # Check if packages to build have been specified, if not, fall back to # the default, doing them all. if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) { - if ($dh{DOINDEP} || $dh{DOARCH} || $dh{DOSAME}) { - error("You asked that all arch in(dep) packages be built, but there are none of that type."); - } push @{$dh{DOPACKAGES}},@allpackages; } @@ -114,13 +102,35 @@ sub init { my $write_log=1; sub END { if ($? == 0 && $write_log) { - my $cmd=basename($0); - foreach my $package (@{$dh{DOPACKAGES}}) { - my $ext=pkgext($package); - open(LOG, ">>", "debian/${ext}debhelper.log") || error("failed to write to log: $!"); - print LOG $cmd."\n"; - close LOG; - } + write_log(basename($0), @{$dh{DOPACKAGES}}); + } +} + +sub load_log { + my ($package, $db)=@_; + my $ext=pkgext($package); + + my @log; + open(LOG, "<", "debian/${ext}debhelper.log") || return; + while () { + chomp; + push @log, $_; + $db->{$package}{$_}=1 if defined $db; + } + close LOG; + return @log; +} + +sub write_log { + my $cmd=shift; + my @packages=@_; + + foreach my $package (@packages) { + my $ext=pkgext($package); + my $log="debian/${ext}debhelper.log"; + open(LOG, ">>", $log) || error("failed to write to ${log}: $!"); + print LOG $cmd."\n"; + close LOG; } } @@ -166,8 +176,7 @@ sub doit { verbose_print(escape_shell(@_)); if (! $dh{NO_ACT}) { - my $ret=system(@_); - $ret == 0 || error("command returned error code $ret"); + system(@_) == 0 || _error_exitcode(join(" ", @_)); } } @@ -180,11 +189,23 @@ sub complex_doit { if (! $dh{NO_ACT}) { # The join makes system get a scalar so it forks off a shell. - system(join(" ",@_)) == 0 - || error("command returned error code"); + system(join(" ", @_)) == 0 || _error_exitcode(join(" ", @_)) } } +sub _error_exitcode { + my $command=shift; + if ($? == -1) { + error("$command failed to to execute: $!"); + } + elsif ($? & 127) { + error("$command died with signal ".($? & 127)); + } + else { + error("$command returned exit code ".($? >> 8)); + } +} + # Run a command that may have a huge number of arguments, like xargs does. # Pass in a reference to an array containing the arguments, and then other # parameters that are the command and any parameters that should be passed to @@ -281,6 +302,7 @@ sub dirname { # Try the file.. open (COMPAT_IN, "debian/compat") || error "debian/compat: $!"; my $l=; + close COMPAT_IN; if (! defined $l || ! length $l) { warning("debian/compat is empty, assuming level $c"); } @@ -292,7 +314,7 @@ sub dirname { } if ($c < 4 && ! $warned_compat) { - warning("Compatibility levels before 4 are deprecated."); + warning("Compatibility levels before 5 are deprecated."); $warned_compat=1; } @@ -326,12 +348,15 @@ sub tmpdir { # # It tries several filenames: # * debian/package.filename.buildarch +# * debian/package.filename.buildos # * debian/package.filename -# * debian/file (if the package is the main package) -# If --name was specified then tonly the first two are tried, and they must -# have the name after the pacage name: +# * debian/filename (if the package is the main package) +# If --name was specified then the files +# must have the name after the package name: # * debian/package.name.filename.buildarch +# * debian/package.name.filename.buildos # * debian/package.name.filename +# * debian/name.filename (if the package is the main package) sub pkgfile { my $package=shift; my $filename=shift; @@ -341,6 +366,7 @@ sub pkgfile { } my @try=("debian/$package.$filename.".buildarch(), + "debian/$package.$filename.".buildos(), "debian/$package.$filename"); if ($package eq $dh{MAINPACKAGE}) { push @try, "debian/$filename"; @@ -581,19 +607,37 @@ sub excludefile { return 0; } +sub dpkg_architecture_value { + my $var = shift; + my $value=`dpkg-architecture -q$var` || error("dpkg-architecture failed"); + chomp $value; + return $value; +} + # Returns the build architecture. (Memoized) { my $arch; sub buildarch { - return $arch if defined $arch; - - $arch=`dpkg-architecture -qDEB_HOST_ARCH 2>/dev/null` || error("dpkg-architecture failed"); - chomp $arch; + if (!defined $arch) { + $arch=dpkg_architecture_value('DEB_HOST_ARCH'); + } return $arch; } } +# Returns the build OS. (Memoized) +{ + my $os; + + sub buildos { + if (!defined $os) { + $os=dpkg_architecture_value("DEB_HOST_ARCH_OS"); + } + return $os; + } +} + # Passed an arch and a list of arches to match against, returns true if matched sub samearch { my $arch=shift; @@ -606,10 +650,26 @@ sub samearch { return 0; } +# Returns source package name +sub sourcepackage { + open (CONTROL, 'debian/control') || + error("cannot read debian/control: $!\n"); + while () { + chomp; + s/\s+$//; + if (/^Source:\s*(.*)/) { + close CONTROL; + return $1; + } + } + + close CONTROL; + error("could not find Source: line in control file."); +} + # Returns a list of packages in the control file. -# Must pass "arch" or "indep" or "same" to specify arch-dependant or -# -independant or same arch packages. If nothing is specified, returns all -# packages. +# Pass "arch" or "indep" to specify arch-dependant or +# independant. If nothing is specified, returns all packages. # As a side effect, populates %package_arches and %package_types with the # types of all packages (not only those returned). my (%package_types, %package_arches); @@ -620,12 +680,6 @@ sub getpackages { %package_arches=(); $type="" if ! defined $type; - - # Look up the build arch if we need to. - my $buildarch=''; - if ($type eq 'same') { - $buildarch=buildarch(); - } my $package=""; my $arch=""; @@ -660,10 +714,12 @@ sub getpackages { $package_types{$package}=$package_type; $package_arches{$package}=$arch; } + if ($package && (($type eq 'indep' && $arch eq 'all') || - ($type eq 'arch' && $arch ne 'all') || - ($type eq 'same' && ($arch eq 'any' || samearch($buildarch, $arch))) || + ($type eq 'arch' && ($arch eq 'any' || + ($arch ne 'all' && + samearch(buildarch(), $arch)))) || ! $type)) { push @list, $package; $package=""; @@ -739,4 +795,32 @@ sub debhelper_script_subst { } } +# Checks if make's jobserver is enabled via MAKEFLAGS, but +# the FD used to communicate with it is actually not available. +sub is_make_jobserver_unavailable { + if (exists $ENV{MAKEFLAGS} && + $ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-fds=(\d+)/) { + if (!open(my $in, "<&$1")) { + return 1; # unavailable + } + else { + close $in; + return 0; # available + } + } + + return; # no jobserver specified +} + +# Cleans out jobserver options from MAKEFLAGS. +sub clean_jobserver_makeflags { + if (exists $ENV{MAKEFLAGS}) { + if ($ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-fds=(\d+)/) { + $ENV{MAKEFLAGS} =~ s/(?:^|\s)--jobserver-fds=\S+//g; + $ENV{MAKEFLAGS} =~ s/(?:^|\s)-j\b//g; + } + delete $ENV{MAKEFLAGS} if $ENV{MAKEFLAGS} =~ /^\s*$/; + } +} + 1