X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debian%2FDebhelper%2FDh_Lib.pm;h=28a90f7bdad16b37900c7021d9b055f2d8f6388b;hb=af351ff3d870c0559afd79fad0341f6a558e3900;hp=ef924b675474475e574f7b8044407d179347bba9;hpb=c89efb0352c6c4af78bc8d5ebbe7cb3846ff89f3;p=debhelper.git diff --git a/Debian/Debhelper/Dh_Lib.pm b/Debian/Debhelper/Dh_Lib.pm index ef924b6..28a90f7 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; @@ -11,34 +11,47 @@ use Exporter; use vars qw(@ISA @EXPORT %dh); @ISA=qw(Exporter); @EXPORT=qw(&init &doit &complex_doit &verbose_print &error &warning &tmpdir - &pkgfile &pkgext &isnative &autoscript &filearray &GetPackages - &xargs %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 + &inhibit_log &load_log &write_log &dpkg_architecture_value + &sourcepackage); -my $max_compat=3; +my $max_compat=7; sub init { - # If DH_OPTIONS is set, prepend it @ARGV. - if (defined($ENV{DH_OPTIONS})) { - 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. + if (exists $ENV{DH_ALWAYS_EXCLUDE} && length $ENV{DH_ALWAYS_EXCLUDE}) { + push @{$dh{EXCLUDE}}, split(":", $ENV{DH_ALWAYS_EXCLUDE}); + } + + # Generate EXCLUDE_FIND. + if ($dh{EXCLUDE}) { + $dh{EXCLUDE_FIND}=''; + foreach (@{$dh{EXCLUDE}}) { + my $x=$_; + $x=escape_shell($x); + $x=~s/\./\\\\./g; + $dh{EXCLUDE_FIND}.="-regex .\\*$x.\\* -or "; + } + $dh{EXCLUDE_FIND}=~s/ -or $//; + } + # Check to see if DH_VERBOSE environment variable was set, if so, # make sure verbose is on. if (defined $ENV{DH_VERBOSE} && $ENV{DH_VERBOSE} ne "") { @@ -51,19 +64,17 @@ sub init { $dh{NO_ACT}=1; } + my @allpackages=getpackages(); # Get the name of the main binary package (first one listed in - # debian/control). - my @allpackages=GetPackages(); - $dh{MAINPACKAGE}=$allpackages[0]; + # debian/control). Only if the main package was not set on the + # command line. + if (! exists $dh{MAINPACKAGE} || ! defined $dh{MAINPACKAGE}) { + $dh{MAINPACKAGE}=$allpackages[0]; + } # 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}) { - # User specified that all arch (in)dep package be - # built, and there are none of that type. - error("I have no package to act on"); - } push @{$dh{DOPACKAGES}},@allpackages; } @@ -78,20 +89,80 @@ sub init { # the command line may affect it. $dh{FIRSTPACKAGE}=${$dh{DOPACKAGES}}[0]; - # Split the U_PARAMS up into an array. - my $u=$dh{U_PARAMS}; - undef $dh{U_PARAMS}; - if (defined $u) { - push @{$dh{U_PARAMS}}, split(/\s+/,$u); + # If no error handling function was specified, just propigate + # errors out. + if (! exists $dh{ERROR_HANDLER} || ! defined $dh{ERROR_HANDLER}) { + $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 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; } } -# Escapes out shell metacharacters in a line of shell script. +sub inhibit_log { + $write_log=0; +} + +# Pass it an array containing the arguments of a shell command like would +# be run by exec(). It turns that into a line like you might enter at the +# shell, escaping metacharacters and quoting arguments that contain spaces. sub escape_shell { - my $line=shift; - # This list is from _Unix in a Nutshell_. (except '#') - $line=~s/([\s!"\$()*+#;<>?@\[\]\\`|~])/\\$1/g; - return $line; + my @args=@_; + my $line=""; + my @ret; + foreach my $word (@args) { + if ($word=~/\s/) { + # Escape only a few things since it will be quoted. + # Note we use double quotes because you cannot + # escape ' in single quotes, while " can be escaped + # in double. + # This does make -V"foo bar" turn into "-Vfoo bar", + # but that will be parsed identically by the shell + # anyway.. + $word=~s/([\n`\$"\\])/\\$1/g; + push @ret, "\"$word\""; + } + else { + # This list is from _Unix in a Nutshell_. (except '#') + $word=~s/([\s!"\$()*+#;<>?@\[\]\\`|~])/\\$1/g; + push @ret,$word; + } + } + return join(' ', @ret); } # Run a command, and display the command to stdout if verbose mode is on. @@ -101,10 +172,10 @@ sub escape_shell { # Note that this cannot handle complex commands, especially anything # involving redirection. Use complex_doit instead. sub doit { - verbose_print(join(" ",map { escape_shell($_) } @_)); - + verbose_print(escape_shell(@_)); + if (! $dh{NO_ACT}) { - system(@_) == 0 || error("command returned error code"); + system(@_) == 0 || _error_exitcode($_[0]); } } @@ -117,11 +188,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 @@ -185,7 +268,8 @@ sub warning { # Returns the basename of the argument passed to it. sub basename { my $fn=shift; - + + $fn=~s/\/$//g; # ignore trailing slashes $fn=~s:^.*/(.*?)$:$1:; return $fn; } @@ -194,25 +278,51 @@ sub basename { sub dirname { my $fn=shift; + $fn=~s/\/$//g; # ignore trailing slashes $fn=~s:^(.*)/.*?$:$1:; return $fn; } -# Pass in a number, will return true iff the current compatability level +# Pass in a number, will return true iff the current compatibility level # is less than or equal to that number. -sub compat { - my $num=shift; +{ + my $warned_compat=0; + my $c; + + sub compat { + my $num=shift; - my $c=1; - if (defined $ENV{DH_COMPAT}) { - $c=$ENV{DH_COMPAT}; - } + if (! defined $c) { + $c=1; + if (defined $ENV{DH_COMPAT}) { + $c=$ENV{DH_COMPAT}; + } + elsif (-e 'debian/compat') { + # 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"); + } + else { + chomp $l; + $c=$l; + } + } + } - if ($c > $max_compat) { - error("Sorry, but $max_compat is the highest compatability level of debhelper currently supported."); - } + if ($c < 4 && ! $warned_compat) { + warning("Compatibility levels before 5 are deprecated."); + $warned_compat=1; + } + + if ($c > $max_compat) { + error("Sorry, but $max_compat is the highest compatibility level supported by this debhelper."); + } - return ($c <= $num); + return ($c <= $num); + } } # Pass it a name of a binary package, it returns the name of the tmp dir to @@ -224,7 +334,7 @@ sub tmpdir { return $dh{TMPDIR}; } elsif (compat(1) && $package eq $dh{MAINPACKAGE}) { - # This is for back-compatability with the debian/tmp tradition. + # This is for back-compatibility with the debian/tmp tradition. return "debian/tmp"; } else { @@ -237,35 +347,63 @@ 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) +# * 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; - if (-f "debian/$package.$filename.".buildarch()) { - return "debian/$package.$filename.".buildarch(); - } - elsif (-f "debian/$package.$filename") { - return "debian/$package.$filename"; + if (defined $dh{NAME}) { + $filename="$dh{NAME}.$filename"; } - elsif ($package eq $dh{MAINPACKAGE} && -f "debian/$filename") { - return "debian/$filename"; + + my @try=("debian/$package.$filename.".buildarch(), + "debian/$package.$filename.".buildos(), + "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 -# in debian for this package. +# in debian/ for this package. sub pkgext { my $package=shift; - if ($package ne $dh{MAINPACKAGE}) { - return "$package."; + if (compat(1) and $package eq $dh{MAINPACKAGE}) { + return ""; } - return ""; + return "$package."; +} + +# Pass it the name of a binary package, it returns the name to install +# files by in eg, etc. Normally this is the same, but --name can override +# it. +sub pkgfilename { + my $package=shift; + + if (defined $dh{NAME}) { + return $dh{NAME}; + } + return $package; } # Returns 1 if the package is a native debian package, null otherwise. @@ -316,7 +454,7 @@ sub autoscript { 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. @@ -334,22 +472,104 @@ 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"); + complex_doit("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"); + complex_doit("sed \"$sed\" $infile >> $outfile"); + complex_doit("echo '# End automatically added section' >> $outfile"); + } } -# Reads in the specified file, one word at a time, and returns an array of -# the result. If a value is passed in as the second parameter, then glob +# Removes a whole substvar line. +sub delsubstvar { + my $package=shift; + my $substvar=shift; + + my $ext=pkgext($package); + my $substvarfile="debian/${ext}substvars"; + + if (-e $substvarfile) { + complex_doit("grep -s -v '^${substvar}=' $substvarfile > $substvarfile.new || true"); + doit("mv", "$substvarfile.new","$substvarfile"); + } +} + +# Adds a dependency on some package to the specified +# substvar in a package's substvar's file. +sub addsubstvar { + my $package=shift; + my $substvar=shift; + my $deppackage=shift; + my $verinfo=shift; + my $remove=shift; + + my $ext=pkgext($package); + my $substvarfile="debian/${ext}substvars"; + my $str=$deppackage; + $str.=" ($verinfo)" if defined $verinfo && length $verinfo; + + # Figure out what the line will look like, based on what's there + # now, and what we're to add or remove. + my $line=""; + if (-e $substvarfile) { + my %items; + open(SUBSTVARS_IN, "$substvarfile") || error "read $substvarfile: $!"; + while () { + chomp; + if (/^\Q$substvar\E=(.*)/) { + %items = map { $_ => 1} split(", ", $1); + + last; + } + } + close SUBSTVARS_IN; + if (! $remove) { + $items{$str}=1; + } + else { + delete $items{$str}; + } + $line=join(", ", sort keys %items); + } + elsif (! $remove) { + $line=$str; + } + + if (length $line) { + complex_doit("(grep -s -v ${substvar} $substvarfile; echo ".escape_shell("${substvar}=$line").") > $substvarfile.new"); + doit("mv", "$substvarfile.new", $substvarfile); + } + else { + delsubstvar($package,$substvar); + } +} + +# Reads in the specified file, one line at a time. splits on words, +# and returns an array of arrays of the contents. +# If a value is passed in as the second parameter, then glob # expansion is done in the directory specified by the parameter ("." is # frequently a good choice). -sub filearray { +sub filedoublearray { my $file=shift; my $globdir=shift; 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)) { + next if /^#/ || /^$/; + } + my @line; # Only do glob expansion in v3 mode. # # The tricky bit is that the glob expansion is done @@ -358,37 +578,107 @@ sub filearray { if (defined $globdir && ! compat(2)) { for (map { glob "$globdir/$_" } split) { s#^$globdir/##; - push @ret, $_; + push @line, $_; } } else { - push @ret, split; + @line = split; } + push @ret, [@line]; } close DH_FARRAY_IN; return @ret; } +# Reads in the specified file, one word at a time, and returns an array of +# the result. Can do globbing as does filedoublearray. +sub filearray { + return map { @$_ } filedoublearray(@_); +} + +# Passed a filename, returns true if -X says that file should be excluded. +sub excludefile { + my $filename = shift; + foreach my $f (@{$dh{EXCLUDE}}) { + return 1 if $filename =~ /\Q$f\E/; + } + return 0; +} + +sub dpkg_architecture_value { + my $var = shift; + my $value=`dpkg-architecture -q$var 2>/dev/null` || error("dpkg-architecture failed"); + chomp $value; + return $value; +} + # Returns the build architecture. (Memoized) { my $arch; sub buildarch { - return $arch if defined $arch; - - $arch=`dpkg --print-architecture` || error($!); - chomp $arch; + if (!defined $arch) { + $arch=dpkg_architecture_value('DEB_HOST_ARCH'); + } return $arch; } } +# Returns the build OS. (Memoized) +{ + my $os; + + sub buildos { + return $os if defined $os; + + $os=`dpkg-architecture -qDEB_HOST_ARCH_OS 2>/dev/null` || error("dpkg-architecture failed"); + chomp $os; + return $os; + } +} + +# Passed an arch and a list of arches to match against, returns true if matched +sub samearch { + my $arch=shift; + my @archlist=split(/\s+/,shift); + + foreach my $a (@archlist) { + system("dpkg-architecture", "-a$arch", "-i$a") == 0 && return 1; + } + + 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. -sub GetPackages { +# 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); +sub getpackages { my $type=shift; + + %package_types=(); + %package_arches=(); $type="" if ! defined $type; @@ -400,7 +690,9 @@ sub GetPackages { my $package=""; my $arch=""; + my $package_type; my @list=(); + my %seen; open (CONTROL, 'debian/control') || error("cannot read debian/control: $!\n"); while () { @@ -408,15 +700,31 @@ sub GetPackages { s/\s+$//; if (/^Package:\s*(.*)/) { $package=$1; + # Detect duplicate package names in the same control file. + if (! $seen{$package}) { + $seen{$package}=1; + } + else { + error("debian/control has a duplicate entry for $package"); + } + $package_type="deb"; } if (/^Architecture:\s*(.*)/) { $arch=$1; } + if (/^(?:X[BC]*-)?Package-Type:\s*(.*)/) { + $package_type=$1; + } + if (!$_ or eof) { # end of stanza. + if ($package) { + $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 'same' && ($arch eq 'any' || samearch($buildarch, $arch))) || ! $type)) { push @list, $package; $package=""; @@ -429,4 +737,67 @@ sub GetPackages { return @list; } +# Returns the arch a package will build for. +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(); +} + +# Return true if a given package is really a udeb. +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'; +} + +# Generates the filename that is used for a udeb package. +sub udeb_filename { + my $package=shift; + + my $filearch=package_arch($package); + isnative($package); # side effect + my $version=$dh{VERSION}; + $version=~s/^[0-9]+://; # strip any epoch + return "${package}_${version}_$filearch.udeb"; +} + +# Handles #DEBHELPER# substitution in a script; also can generate a new +# script from scratch if none exists but there is a .debhelper file for it. +sub debhelper_script_subst { + my $package=shift; + my $script=shift; + + my $tmp=tmpdir($package); + my $ext=pkgext($package); + my $file=pkgfile($package,$script); + + if ($file ne '') { + if (-f "debian/$ext$script.debhelper") { + # Add this into the script, where it has #DEBHELPER# + complex_doit("perl -pe 's~#DEBHELPER#~qx{cat debian/$ext$script.debhelper}~eg' < $file > $tmp/DEBIAN/$script"); + } + else { + # Just get rid of any #DEBHELPER# in the script. + complex_doit("sed s/#DEBHELPER#// < $file > $tmp/DEBIAN/$script"); + } + doit("chown","0:0","$tmp/DEBIAN/$script"); + doit("chmod",755,"$tmp/DEBIAN/$script"); + } + elsif ( -f "debian/$ext$script.debhelper" ) { + complex_doit("printf '#!/bin/sh\nset -e\n' > $tmp/DEBIAN/$script"); + complex_doit("cat debian/$ext$script.debhelper >> $tmp/DEBIAN/$script"); + doit("chown","0:0","$tmp/DEBIAN/$script"); + doit("chmod",755,"$tmp/DEBIAN/$script"); + } +} + 1