X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debian%2FDebhelper%2FDh_Lib.pm;h=c83e42b266aa20f64284399c65610f0604100ca1;hb=a3494762925e5a42a42ce82c688f62f163ffad1b;hp=f1b39226be061c4e7fa86475202f0885138b4e21;hpb=0b49e3bc664a3d10b3a54359b8aa4b8d5e505eb2;p=debhelper.git diff --git a/Debian/Debhelper/Dh_Lib.pm b/Debian/Debhelper/Dh_Lib.pm index f1b3922..7b550b0 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; @@ -14,34 +14,27 @@ use vars qw(@ISA @EXPORT %dh); &pkgfile &pkgext &pkgfilename &isnative &autoscript &filearray &filedoublearray &getpackages &basename &dirname &xargs %dh &compat &addsubstvar &delsubstvar &excludefile &package_arch - &is_udeb &udeb_filename &debhelper_script_subst &escape_shell); + &is_udeb &udeb_filename &debhelper_script_subst &escape_shell + &inhibit_log &load_log &write_log &commit_override_log + &dpkg_architecture_value &sourcepackage + &is_make_jobserver_unavailable &clean_jobserver_makeflags + &cross_command &set_buildflags &get_buildoption); -my $max_compat=5; +my $max_compat=10; 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); } # Another way to set excludes. @@ -55,7 +48,7 @@ sub init { foreach (@{$dh{EXCLUDE}}) { my $x=$_; $x=escape_shell($x); - $x=~s/\./\\./g; + $x=~s/\./\\\\./g; $dh{EXCLUDE_FIND}.="-regex .\\*$x.\\* -or "; } $dh{EXCLUDE_FIND}=~s/ -or $//; @@ -73,21 +66,18 @@ sub init { $dh{NO_ACT}=1; } - my @allpackages=getpackages(); # Get the name of the main binary package (first one listed in # debian/control). Only if the main package was not set on the # command line. if (! exists $dh{MAINPACKAGE} || ! defined $dh{MAINPACKAGE}) { + my @allpackages=getpackages(); $dh{MAINPACKAGE}=$allpackages[0]; } # Check if packages to build have been specified, if not, fall back to - # the default, doing them all. + # the default, building all relevant packages. 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; + push @{$dh{DOPACKAGES}}, getpackages('both'); } # Check to see if -P was specified. If so, we can only act on a single @@ -104,8 +94,84 @@ sub init { # If no error handling function was specified, just propigate # errors out. if (! exists $dh{ERROR_HANDLER} || ! defined $dh{ERROR_HANDLER}) { - $dh{ERROR_HANDLER}='exit $?'; + $dh{ERROR_HANDLER}='exit \$?'; + } +} + +# Run at exit. Add the command to the log files for the packages it acted +# on, if it's exiting successfully. +my $write_log=1; +sub END { + if ($? == 0 && $write_log) { + write_log(basename($0), @{$dh{DOPACKAGES}}); + } +} + +sub logfile { + my $package=shift; + my $ext=pkgext($package); + return "debian/${ext}debhelper.log" +} + +sub add_override { + my $line=shift; + $line="override_$ENV{DH_INTERNAL_OVERRIDE} $line" + if defined $ENV{DH_INTERNAL_OVERRIDE}; + return $line; +} + +sub remove_override { + my $line=shift; + $line=~s/^\Qoverride_$ENV{DH_INTERNAL_OVERRIDE}\E\s+// + if defined $ENV{DH_INTERNAL_OVERRIDE}; + return $line; +} + +sub load_log { + my ($package, $db)=@_; + + my @log; + open(LOG, "<", logfile($package)) || return; + while () { + chomp; + my $command=remove_override($_); + push @log, $command; + $db->{$package}{$command}=1 if defined $db; } + close LOG; + return @log; +} + +sub write_log { + my $cmd=shift; + my @packages=@_; + + return if $dh{NO_ACT}; + + foreach my $package (@packages) { + my $log=logfile($package); + open(LOG, ">>", $log) || error("failed to write to ${log}: $!"); + print LOG add_override($cmd)."\n"; + close LOG; + } +} + +sub commit_override_log { + my @packages=@_; + + return if $dh{NO_ACT}; + + foreach my $package (@packages) { + my @log=map { remove_override($_) } load_log($package); + my $log=logfile($package); + open(LOG, ">", $log) || error("failed to write to ${log}: $!"); + print LOG $_."\n" foreach @log; + close LOG; + } +} + +sub inhibit_log { + $write_log=0; } # Pass it an array containing the arguments of a shell command like would @@ -146,8 +212,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(" ", @_)); } } @@ -160,11 +225,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 @@ -174,6 +251,7 @@ sub xargs { # The kernel can accept command lines up to 20k worth of characters. my $command_max=20000; # LINUX SPECIFIC!! + # (And obsolete; it's bigger now.) # I could use POSIX::ARG_MAX, but that would be slow. # Figure out length of static portion of command. @@ -210,12 +288,11 @@ sub verbose_print { } } -# Output an error message and exit. +# Output an error message and die (can be caught). sub error { my $message=shift; - warning($message); - exit 1; + die basename($0).": $message\n"; } # Output a warning. @@ -251,28 +328,35 @@ sub dirname { sub compat { my $num=shift; + my $nowarn=shift; if (! defined $c) { $c=1; - if (defined $ENV{DH_COMPAT}) { - $c=$ENV{DH_COMPAT}; - } - elsif (-e 'debian/compat') { - # Try the file.. + if (-e 'debian/compat') { 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"); + warning("debian/compat is empty, assuming level $c") + unless defined $ENV{DH_COMPAT}; } else { chomp $l; $c=$l; } } + else { + warning("No compatibility level specified in debian/compat"); + warning("This package will soon FTBFS; time to fix it!"); + } + + if (defined $ENV{DH_COMPAT}) { + $c=$ENV{DH_COMPAT}; + } } - if ($c < 4 && ! $warned_compat) { - warning("Compatibility levels before 4 are deprecated."); + if ($c <= 4 && ! $warned_compat && ! $nowarn) { + warning("Compatibility levels before 5 are deprecated (level $c in use)"); $warned_compat=1; } @@ -306,12 +390,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; @@ -320,18 +407,37 @@ sub pkgfile { $filename="$dh{NAME}.$filename"; } - if (-f "debian/$package.$filename.".buildarch()) { - return "debian/$package.$filename.".buildarch(); - } - elsif (-f "debian/$package.$filename") { - return "debian/$package.$filename"; + # First, check for files ending in buildarch and buildos. + my $match; + foreach my $file (glob("debian/$package.$filename.*")) { + next if ! -f $file; + next if $dh{IGNORE} && exists $dh{IGNORE}->{$file}; + if ($file eq "debian/$package.$filename.".buildarch()) { + $match=$file; + # buildarch files are used in preference to buildos files. + last; + } + elsif ($file eq "debian/$package.$filename.".buildos()) { + $match=$file; + } } - elsif ($package eq $dh{MAINPACKAGE} && -f "debian/$filename") { - return "debian/$filename"; + return $match if defined $match; + + my @try=("debian/$package.$filename"); + if ($package eq $dh{MAINPACKAGE}) { + push @try, "debian/$filename"; } - else { - return ""; + + foreach my $file (@try) { + if (-f $file && + (! $dh{IGNORE} || ! exists $dh{IGNORE}->{$file})) { + return $file; + } + } + + return ""; + } # Pass it a name of a binary package, it returns the name to prefix to files @@ -398,14 +504,15 @@ sub pkgfilename { # 1: package # 2: script to add to # 3: filename of snippet -# 4: sed to run on the snippet. Ie, s/#PACKAGE#/$PACKAGE/ +# 4: either text: shell-quoted sed to run on the snippet. Ie, 's/#PACKAGE#/$PACKAGE/' +# or a sub to run on each line of the snippet. Ie sub { s/#PACKAGE#/$PACKAGE/ } sub autoscript { my $package=shift; my $script=shift; my $filename=shift; my $sed=shift || ""; - # This is the file we will append to. + # This is the file we will modify. my $outfile="debian/".pkgext($package)."$script.debhelper"; # Figure out what shell script snippet to use. @@ -423,9 +530,36 @@ sub autoscript { } } - complex_doit("echo \"# Automatically added by ".basename($0)."\">> $outfile"); - complex_doit("sed \"$sed\" $infile >> $outfile"); - complex_doit("echo '# End automatically added section' >> $outfile"); + if (-e $outfile && ($script eq 'postrm' || $script eq 'prerm') + && !compat(5)) { + # Add fragments to top so they run in reverse order when removing. + complex_doit("echo \"# Automatically added by ".basename($0)."\"> $outfile.new"); + autoscript_sed($sed, $infile, "$outfile.new"); + complex_doit("echo '# End automatically added section' >> $outfile.new"); + complex_doit("cat $outfile >> $outfile.new"); + complex_doit("mv $outfile.new $outfile"); + } + else { + complex_doit("echo \"# Automatically added by ".basename($0)."\">> $outfile"); + autoscript_sed($sed, $infile, $outfile); + complex_doit("echo '# End automatically added section' >> $outfile"); + } +} + +sub autoscript_sed { + my $sed = shift; + my $infile = shift; + my $outfile = shift; + if (ref($sed) eq 'CODE') { + open(IN, $infile) or die "$infile: $!"; + open(OUT, ">>$outfile") or die "$outfile: $!"; + while () { $sed->(); print OUT } + close(OUT) or die "$outfile: $!"; + close(IN) or die "$infile: $!"; + } + else { + complex_doit("sed \"$sed\" $infile >> $outfile"); + } } # Removes a whole substvar line. @@ -477,7 +611,7 @@ sub addsubstvar { else { delete $items{$str}; } - $line=join(", ", keys %items); + $line=join(", ", sort keys %items); } elsif (! $remove) { $line=$str; @@ -501,12 +635,22 @@ sub filedoublearray { my $file=shift; my $globdir=shift; + # executable config files are a v9 thing. + my $x=! compat(8) && -x $file; + if ($x) { + require Cwd; + my $cmd=Cwd::abs_path($file); + open (DH_FARRAY_IN, "$cmd |") || error("cannot run $file: $!"); + } + else { + open (DH_FARRAY_IN, $file) || error("cannot read $file: $!"); + } + my @ret; - open (DH_FARRAY_IN, $file) || error("cannot read $file: $1"); while () { chomp; # Only ignore comments and empty lines in v5 mode. - if (! compat(4)) { + if (! compat(4) && ! $x) { next if /^#/ || /^$/; } my @line; @@ -515,8 +659,8 @@ sub filedoublearray { # The tricky bit is that the glob expansion is done # as if we were in the specified directory, so the # filenames that come out are relative to it. - if (defined $globdir && ! compat(2)) { - for (map { glob "$globdir/$_" } split) { + if (defined $globdir && ! compat(2) && ! $x) { + foreach (map { glob "$globdir/$_" } split) { s#^$globdir/##; push @line, $_; } @@ -526,7 +670,8 @@ sub filedoublearray { } push @ret, [@line]; } - close DH_FARRAY_IN; + + close DH_FARRAY_IN || error("problem reading $file: $!"); return @ret; } @@ -546,22 +691,87 @@ sub excludefile { return 0; } -# Returns the build architecture. (Memoized) { - my $arch; + my %dpkg_arch_output; + sub dpkg_architecture_value { + my $var = shift; + if (! exists($dpkg_arch_output{$var})) { + local $_; + open(PIPE, '-|', 'dpkg-architecture') + or error("dpkg-architecture failed"); + while () { + chomp; + my ($k, $v) = split(/=/, $_, 2); + $dpkg_arch_output{$k} = $v; + } + close(PIPE); + } + return $dpkg_arch_output{$var}; + } +} + +# Returns the build architecture. +sub buildarch { + dpkg_architecture_value('DEB_HOST_ARCH'); +} + +# Returns the build OS. +sub buildos { + dpkg_architecture_value("DEB_HOST_ARCH_OS"); +} + +# Passed an arch and a list of arches to match against, returns true if matched +{ + my %knownsame; + + sub samearch { + my $arch=shift; + my @archlist=split(/\s+/,shift); + + foreach my $a (@archlist) { + # Avoid expensive dpkg-architecture call to compare + # with a simple architecture name. "linux-any" and + # other architecture wildcards are (currently) + # always hypenated. + if ($a !~ /-/) { + return 1 if $arch eq $a; + } + elsif (exists $knownsame{$arch}{$a}) { + return 1 if $knownsame{$arch}{$a}; + } + elsif (system("dpkg-architecture", "-a$arch", "-i$a") == 0) { + return $knownsame{$arch}{$a}=1; + } + else { + $knownsame{$arch}{$a}=0; + } + } - sub buildarch { - return $arch if defined $arch; + return 0; + } +} - $arch=`dpkg-architecture -qDEB_HOST_ARCH 2>/dev/null` || error($!); - chomp $arch; - return $arch; +# 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 +# Pass "arch" or "indep" to specify arch-dependant (that will be built +# for the system's arch) or independant. If nothing is specified, +# returns all packages. Also, "both" returns the union of "arch" and "indep" # packages. # As a side effect, populates %package_arches and %package_types with the # types of all packages (not only those returned). @@ -573,12 +783,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=""; @@ -604,7 +808,7 @@ sub getpackages { if (/^Architecture:\s*(.*)/) { $arch=$1; } - if (/^X[BC]*-Package-Type:\s*(.*)/) { + if (/^(?:X[BC]*-)?Package-Type:\s*(.*)/) { $package_type=$1; } @@ -613,10 +817,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' || $arch =~ /\b$buildarch\b/)) || + ((($type eq 'indep' || $type eq 'both') && $arch eq 'all') || + (($type eq 'arch' || $type eq 'both') && ($arch eq 'any' || + ($arch ne 'all' && + samearch(buildarch(), $arch)))) || ! $type)) { push @list, $package; $package=""; @@ -633,6 +839,10 @@ sub getpackages { sub package_arch { my $package=shift; + if (! exists $package_arches{$package}) { + warning "package $package is not in control info"; + return buildarch(); + } return $package_arches{$package} eq 'all' ? "all" : buildarch(); } @@ -640,6 +850,10 @@ sub package_arch { sub is_udeb { my $package=shift; + if (! exists $package_types{$package}) { + warning "package $package is not in control info"; + return 0; + } return $package_types{$package} eq 'udeb'; } @@ -684,4 +898,83 @@ 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*$/; + } +} + +# If cross-compiling, returns appropriate cross version of command. +sub cross_command { + my $command=shift; + if (dpkg_architecture_value("DEB_BUILD_GNU_TYPE") + ne dpkg_architecture_value("DEB_HOST_GNU_TYPE")) { + return dpkg_architecture_value("DEB_HOST_GNU_TYPE")."-$command"; + } + else { + return $command; + } +} + +# Sets environment variables from dpkg-buildflags. Avoids changing +# any existing environment variables. +sub set_buildflags { + return if $ENV{DH_INTERNAL_BUILDFLAGS} || compat(8); + $ENV{DH_INTERNAL_BUILDFLAGS}=1; + + eval "use Dpkg::BuildFlags"; + if ($@) { + warning "unable to load build flags: $@"; + return; + } + + my $buildflags = Dpkg::BuildFlags->new(); + $buildflags->load_config(); + foreach my $flag ($buildflags->list()) { + next unless $flag =~ /^[A-Z]/; # Skip flags starting with lowercase + if (! exists $ENV{$flag}) { + $ENV{$flag} = $buildflags->get($flag); + } + } +} + +# Gets a DEB_BUILD_OPTIONS option, if set. +sub get_buildoption { + my $wanted=shift; + + return undef unless exists $ENV{DEB_BUILD_OPTIONS}; + + foreach my $opt (split(/\s+/, $ENV{DEB_BUILD_OPTIONS})) { + # currently parallel= is the only one with a parameter + if ($opt =~ /^parallel=(-?\d+)$/ && $wanted eq 'parallel') { + return $1; + } + elsif ($opt eq $wanted) { + return 1; + } + } +} + 1