X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debian%2FDebhelper%2FDh_Lib.pm;h=345630d75d59695d9a3b54506a318c39bf417f97;hb=dfc48628ab06f010bb18454d5d8e8701b1bcf58a;hp=e17913eda9c9cd5dd0ab84eaf1ba66a61cd8e47d;hpb=053f6f8b4e7431d32511aef209188a084e8c7e79;p=debhelper.git diff --git a/Debian/Debhelper/Dh_Lib.pm b/Debian/Debhelper/Dh_Lib.pm index e17913e..345630d 100644 --- a/Debian/Debhelper/Dh_Lib.pm +++ b/Debian/Debhelper/Dh_Lib.pm @@ -11,14 +11,18 @@ 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 - &basename &xargs %dh &compat); + &pkgfile &pkgext &isnative &autoscript &filearray &filedoublearray + &GetPackages &basename &dirname &xargs %dh &compat &addsubstvar + &delsubstvar &excludefile); -my $max_compat=3; +my $max_compat=4; 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}); } @@ -39,6 +43,23 @@ sub init { %dh=Debian::Debhelper::Dh_Getopt::parseopts(); } + # 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,18 +72,19 @@ sub init { $dh{NO_ACT}=1; } - # Get the name of the main binary package (first one listed in - # debian/control). my @allpackages=GetPackages(); - $dh{MAINPACKAGE}=$allpackages[0]; + # 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}) { + $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"); + error("You asked that all arch in(dep) packages be built, but there are none of that type."); } push @{$dh{DOPACKAGES}},@allpackages; } @@ -77,21 +99,34 @@ sub init { # This package gets special treatement: files and directories specified on # 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); - } } -# Escapes out shell metacharacters in a line of shell script. +# 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 +136,11 @@ 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"); + my $ret=system(@_); + $ret == 0 || error("command returned error code $ret"); } } @@ -185,7 +221,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,11 +231,12 @@ 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; @@ -207,9 +245,15 @@ sub compat { if (defined $ENV{DH_COMPAT}) { $c=$ENV{DH_COMPAT}; } + elsif (-e 'debian/compat') { + # Try the file.. + open (COMPAT_IN, "debian/compat") || error "debian/compat: $!"; + $c=; + chomp $c; + } if ($c > $max_compat) { - error("Sorry, but $max_compat is the highest compatability level of debhelper currently supported."); + error("Sorry, but $max_compat is the highest compatibility level of debhelper currently supported."); } return ($c <= $num); @@ -224,7 +268,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 { @@ -262,10 +306,10 @@ sub pkgfile { sub pkgext { my $package=shift; - if ($package ne $dh{MAINPACKAGE}) { - return "$package."; + if (compat(1) and $package eq $dh{MAINPACKAGE}) { + return ""; } - return ""; + return "$package."; } # Returns 1 if the package is a native debian package, null otherwise. @@ -339,17 +383,83 @@ sub autoscript { 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(", ", 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 () { + my @line; # Only do glob expansion in v3 mode. # # The tricky bit is that the glob expansion is done @@ -358,18 +468,34 @@ 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; +} + # Returns the build architecture. (Memoized) { my $arch; @@ -377,7 +503,7 @@ sub filearray { sub buildarch { return $arch if defined $arch; - $arch=`dpkg --print-architecture` || error($!); + $arch=`dpkg-architecture -qDEB_HOST_ARCH 2>/dev/null` || error($!); chomp $arch; return $arch; } @@ -401,6 +527,7 @@ sub GetPackages { my $package=""; my $arch=""; my @list=(); + my %seen; open (CONTROL, 'debian/control') || error("cannot read debian/control: $!\n"); while () { @@ -408,10 +535,18 @@ 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"); + } } if (/^Architecture:\s*(.*)/) { $arch=$1; } + if (!$_ or eof) { # end of stanza. if ($package && (($type eq 'indep' && $arch eq 'all') ||