Debian/Debhelper/Dh_Lib.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # Library functions for debhelper programs, perl version.
   4 #
   5 # Joey Hess, GPL copyright 1997-2000.
   6
   7 package Debian::Debhelper::Dh_Lib;
   8 use strict;
   9
  10 use Exporter;
  11 use vars qw(@ISA @EXPORT %dh);
  12 @ISA=qw(Exporter);
  13 @EXPORT=qw(&init &doit &complex_doit &verbose_print &error &warning &tmpdir
  14             &pkgfile &pkgext &pkgfilename &isnative &autoscript &filearray
  15             &filedoublearray &getpackages &basename &dirname &xargs %dh
  16             &compat &addsubstvar &delsubstvar &excludefile &package_arch
  17             &is_udeb &udeb_filename &debhelper_script_subst &escape_shell
  18             &inhibit_log);
  19
  20 my $max_compat=7;
  21
  22 sub init {
  23         # If DH_OPTIONS is set, prepend it @ARGV.
  24         if (defined($ENV{DH_OPTIONS})) {
  25                 # Ignore leading/trailing whitespace.
  26                 $ENV{DH_OPTIONS}=~s/^\s+//;
  27                 $ENV{DH_OPTIONS}=~s/\s+$//;
  28                 unshift @ARGV,split(/\s+/,$ENV{DH_OPTIONS});
  29         }
  30
  31         # Check to see if an argument on the command line starts with a dash.
  32         # if so, we need to pass this off to the resource intensive
  33         # Getopt::Long, which I'd prefer to avoid loading at all if possible.
  34         my $parseopt=undef;
  35         my $arg;
  36         foreach $arg (@ARGV) {
  37                 if ($arg=~m/^-/) {
  38                         $parseopt=1;
  39                         last;
  40                 }
  41         }
  42         if ($parseopt) {
  43                 eval "use Debian::Debhelper::Dh_Getopt";
  44                 error($!) if $@;
  45                 %dh=Debian::Debhelper::Dh_Getopt::parseopts();
  46         }
  47
  48         # Another way to set excludes.
  49         if (exists $ENV{DH_ALWAYS_EXCLUDE} && length $ENV{DH_ALWAYS_EXCLUDE}) {
  50                 push @{$dh{EXCLUDE}}, split(":", $ENV{DH_ALWAYS_EXCLUDE});
  51         }
  52
  53         # Generate EXCLUDE_FIND.
  54         if ($dh{EXCLUDE}) {
  55                 $dh{EXCLUDE_FIND}='';
  56                 foreach (@{$dh{EXCLUDE}}) {
  57                         my $x=$_;
  58                         $x=escape_shell($x);
  59                         $x=~s/\./\\\\./g;
  60                         $dh{EXCLUDE_FIND}.="-regex .\\*$x.\\* -or ";
  61                 }
  62                 $dh{EXCLUDE_FIND}=~s/ -or $//;
  63         }
  64
  65         # Check to see if DH_VERBOSE environment variable was set, if so,
  66         # make sure verbose is on.
  67         if (defined $ENV{DH_VERBOSE} && $ENV{DH_VERBOSE} ne "") {
  68                 $dh{VERBOSE}=1;
  69         }
  70
  71         # Check to see if DH_NO_ACT environment variable was set, if so,
  72         # make sure no act mode is on.
  73         if (defined $ENV{DH_NO_ACT} && $ENV{DH_NO_ACT} ne "") {
  74                 $dh{NO_ACT}=1;
  75         }
  76
  77         my @allpackages=getpackages();
  78         # Get the name of the main binary package (first one listed in
  79         # debian/control). Only if the main package was not set on the
  80         # command line.
  81         if (! exists $dh{MAINPACKAGE} || ! defined $dh{MAINPACKAGE}) {
  82                 $dh{MAINPACKAGE}=$allpackages[0];
  83         }
  84
  85         # Check if packages to build have been specified, if not, fall back to
  86         # the default, doing them all.
  87         if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) {
  88                 if ($dh{DOINDEP} || $dh{DOARCH} || $dh{DOSAME}) {
  89                         error("You asked that all arch in(dep) packages be built, but there are none of that type.");
  90                 }
  91                 push @{$dh{DOPACKAGES}},@allpackages;
  92         }
  93
  94         # Check to see if -P was specified. If so, we can only act on a single
  95         # package.
  96         if ($dh{TMPDIR} && $#{$dh{DOPACKAGES}} > 0) {
  97                 error("-P was specified, but multiple packages would be acted on (".join(",",@{$dh{DOPACKAGES}}).").");
  98         }
  99
 100         # Figure out which package is the first one we were instructed to build.
 101         # This package gets special treatement: files and directories specified on
 102         # the command line may affect it.
 103         $dh{FIRSTPACKAGE}=${$dh{DOPACKAGES}}[0];
 104
 105         # If no error handling function was specified, just propigate
 106         # errors out.
 107         if (! exists $dh{ERROR_HANDLER} || ! defined $dh{ERROR_HANDLER}) {
 108                 $dh{ERROR_HANDLER}='exit \$?';
 109         }
 110 }
 111
 112 # Run at exit. Add the command to the log files for the packages it acted
 113 # on, if it's exiting successfully.
 114 my $write_log=1;
 115 sub END {
 116         if ($? == 0 && $write_log) {
 117                 my $cmd=basename($0);
 118                 foreach my $package (@{$dh{DOPACKAGES}}) {
 119                         my $ext=pkgext($package);
 120                         my $log="debian/${ext}debhelper.log";
 121                         open(LOG, ">>", $log) || error("failed to write to ${log}: $!");
 122                         print LOG $cmd."\n";
 123                         close LOG;
 124                 }
 125         }
 126 }
 127
 128 sub inhibit_log {
 129         $write_log=0;
 130 }
 131
 132 # Pass it an array containing the arguments of a shell command like would
 133 # be run by exec(). It turns that into a line like you might enter at the
 134 # shell, escaping metacharacters and quoting arguments that contain spaces.
 135 sub escape_shell {
 136         my @args=@_;
 137         my $line="";
 138         my @ret;
 139         foreach my $word (@args) {
 140                 if ($word=~/\s/) {
 141                         # Escape only a few things since it will be quoted.
 142                         # Note we use double quotes because you cannot
 143                         # escape ' in single quotes, while " can be escaped
 144                         # in double.
 145                         # This does make -V"foo bar" turn into "-Vfoo bar",
 146                         # but that will be parsed identically by the shell
 147                         # anyway..
 148                         $word=~s/([\n`\$"\\])/\\$1/g;
 149                         push @ret, "\"$word\"";
 150                 }
 151                 else {
 152                         # This list is from _Unix in a Nutshell_. (except '#')
 153                         $word=~s/([\s!"\$()*+#;<>?@\[\]\\`|~])/\\$1/g;
 154                         push @ret,$word;
 155                 }
 156         }
 157         return join(' ', @ret);
 158 }
 159
 160 # Run a command, and display the command to stdout if verbose mode is on.
 161 # All commands that modifiy files in $TMP should be ran via this
 162 # function.
 163 #
 164 # Note that this cannot handle complex commands, especially anything
 165 # involving redirection. Use complex_doit instead.
 166 sub doit {
 167         verbose_print(escape_shell(@_));
 168
 169         if (! $dh{NO_ACT}) {
 170                 my $ret=system(@_);
 171                 $ret == 0 || error("command returned error code $ret");
 172         }
 173 }
 174
 175 # Run a command and display the command to stdout if verbose mode is on.
 176 # Use doit() if you can, instead of this function, because this function
 177 # forks a shell. However, this function can handle more complicated stuff
 178 # like redirection.
 179 sub complex_doit {
 180         verbose_print(join(" ",@_));
 181
 182         if (! $dh{NO_ACT}) {
 183                 # The join makes system get a scalar so it forks off a shell.
 184                 system(join(" ",@_)) == 0
 185                         || error("command returned error code");
 186         }
 187 }
 188
 189 # Run a command that may have a huge number of arguments, like xargs does.
 190 # Pass in a reference to an array containing the arguments, and then other
 191 # parameters that are the command and any parameters that should be passed to
 192 # it each time.
 193 sub xargs {
 194         my $args=shift;
 195
 196         # The kernel can accept command lines up to 20k worth of characters.
 197         my $command_max=20000; # LINUX SPECIFIC!!
 198                         # I could use POSIX::ARG_MAX, but that would be slow.
 199
 200         # Figure out length of static portion of command.
 201         my $static_length=0;
 202         foreach (@_) {
 203                 $static_length+=length($_)+1;
 204         }
 205
 206         my @collect=();
 207         my $length=$static_length;
 208         foreach (@$args) {
 209                 if (length($_) + 1 + $static_length > $command_max) {
 210                         error("This command is greater than the maximum command size allowed by the kernel, and cannot be split up further. What on earth are you doing? \"@_ $_\"");
 211                 }
 212                 $length+=length($_) + 1;
 213                 if ($length < $command_max) {
 214                         push @collect, $_;
 215                 }
 216                 else {
 217                         doit(@_,@collect) if $#collect > -1;
 218                         @collect=($_);
 219                         $length=$static_length + length($_) + 1;
 220                 }
 221         }
 222         doit(@_,@collect) if $#collect > -1;
 223 }
 224
 225 # Print something if the verbose flag is on.
 226 sub verbose_print {
 227         my $message=shift;
 228
 229         if ($dh{VERBOSE}) {
 230                 print "\t$message\n";
 231         }
 232 }
 233
 234 # Output an error message and exit.
 235 sub error {
 236         my $message=shift;
 237
 238         warning($message);
 239         exit 1;
 240 }
 241
 242 # Output a warning.
 243 sub warning {
 244         my $message=shift;
 245
 246         print STDERR basename($0).": $message\n";
 247 }
 248
 249 # Returns the basename of the argument passed to it.
 250 sub basename {
 251         my $fn=shift;
 252
 253         $fn=~s/\/$//g; # ignore trailing slashes
 254         $fn=~s:^.*/(.*?)$:$1:;
 255         return $fn;
 256 }
 257
 258 # Returns the directory name of the argument passed to it.
 259 sub dirname {
 260         my $fn=shift;
 261
 262         $fn=~s/\/$//g; # ignore trailing slashes
 263         $fn=~s:^(.*)/.*?$:$1:;
 264         return $fn;
 265 }
 266
 267 # Pass in a number, will return true iff the current compatibility level
 268 # is less than or equal to that number.
 269 {
 270         my $warned_compat=0;
 271         my $c;
 272
 273         sub compat {
 274                 my $num=shift;
 275
 276                 if (! defined $c) {
 277                         $c=1;
 278                         if (defined $ENV{DH_COMPAT}) {
 279                                 $c=$ENV{DH_COMPAT};
 280                         }
 281                         elsif (-e 'debian/compat') {
 282                                 # Try the file..
 283                                 open (COMPAT_IN, "debian/compat") || error "debian/compat: $!";
 284                                 my $l=<COMPAT_IN>;
 285                                 if (! defined $l || ! length $l) {
 286                                         warning("debian/compat is empty, assuming level $c");
 287                                 }
 288                                 else {
 289                                         chomp $l;
 290                                         $c=$l;
 291                                 }
 292                         }
 293                 }
 294
 295                 if ($c < 4 && ! $warned_compat) {
 296                         warning("Compatibility levels before 4 are deprecated.");
 297                         $warned_compat=1;
 298                 }
 299
 300                 if ($c > $max_compat) {
 301                         error("Sorry, but $max_compat is the highest compatibility level supported by this debhelper.");
 302                 }
 303
 304                 return ($c <= $num);
 305         }
 306 }
 307
 308 # Pass it a name of a binary package, it returns the name of the tmp dir to
 309 # use, for that package.
 310 sub tmpdir {
 311         my $package=shift;
 312
 313         if ($dh{TMPDIR}) {
 314                 return $dh{TMPDIR};
 315         }
 316         elsif (compat(1) && $package eq $dh{MAINPACKAGE}) {
 317                 # This is for back-compatibility with the debian/tmp tradition.
 318                 return "debian/tmp";
 319         }
 320         else {
 321                 return "debian/$package";
 322         }
 323 }
 324
 325 # Pass this the name of a binary package, and the name of the file wanted
 326 # for the package, and it will return the actual existing filename to use.
 327 #
 328 # It tries several filenames:
 329 #   * debian/package.filename.buildarch
 330 #   * debian/package.filename
 331 #   * debian/file (if the package is the main package)
 332 # If --name was specified then tonly the first two are tried, and they must
 333 # have the name after the pacage name:
 334 #   * debian/package.name.filename.buildarch
 335 #   * debian/package.name.filename
 336 sub pkgfile {
 337         my $package=shift;
 338         my $filename=shift;
 339
 340         if (defined $dh{NAME}) {
 341                 $filename="$dh{NAME}.$filename";
 342         }
 343
 344         my @try=("debian/$package.$filename.".buildarch(),
 345                  "debian/$package.$filename");
 346         if ($package eq $dh{MAINPACKAGE}) {
 347                 push @try, "debian/$filename";
 348         }
 349
 350         foreach my $file (@try) {
 351                 if (-f $file &&
 352                     (! $dh{IGNORE} || ! exists $dh{IGNORE}->{$file})) {
 353                         return $file;
 354                 }
 355
 356         }
 357
 358         return "";
 359
 360 }
 361
 362 # Pass it a name of a binary package, it returns the name to prefix to files
 363 # in debian/ for this package.
 364 sub pkgext {
 365         my $package=shift;
 366
 367         if (compat(1) and $package eq $dh{MAINPACKAGE}) {
 368                 return "";
 369         }
 370         return "$package.";
 371 }
 372
 373 # Pass it the name of a binary package, it returns the name to install
 374 # files by in eg, etc. Normally this is the same, but --name can override
 375 # it.
 376 sub pkgfilename {
 377         my $package=shift;
 378
 379         if (defined $dh{NAME}) {
 380                 return $dh{NAME};
 381         }
 382         return $package;
 383 }
 384
 385 # Returns 1 if the package is a native debian package, null otherwise.
 386 # As a side effect, sets $dh{VERSION} to the version of this package.
 387 {
 388         # Caches return code so it only needs to run dpkg-parsechangelog once.
 389         my %isnative_cache;
 390
 391         sub isnative {
 392                 my $package=shift;
 393
 394                 return $isnative_cache{$package} if defined $isnative_cache{$package};
 395
 396                 # Make sure we look at the correct changelog.
 397                 my $isnative_changelog=pkgfile($package,"changelog");
 398                 if (! $isnative_changelog) {
 399                         $isnative_changelog="debian/changelog";
 400                 }
 401                 # Get the package version.
 402                 my $version=`dpkg-parsechangelog -l$isnative_changelog`;
 403                 ($dh{VERSION})=$version=~m/Version:\s*(.*)/m;
 404                 # Did the changelog parse fail?
 405                 if (! defined $dh{VERSION}) {
 406                         error("changelog parse failure");
 407                 }
 408
 409                 # Is this a native Debian package?
 410                 if ($dh{VERSION}=~m/.*-/) {
 411                         return $isnative_cache{$package}=0;
 412                 }
 413                 else {
 414                         return $isnative_cache{$package}=1;
 415                 }
 416         }
 417 }
 418
 419 # Automatically add a shell script snippet to a debian script.
 420 # Only works if the script has #DEBHELPER# in it.
 421 #
 422 # Parameters:
 423 # 1: package
 424 # 2: script to add to
 425 # 3: filename of snippet
 426 # 4: sed to run on the snippet. Ie, s/#PACKAGE#/$PACKAGE/
 427 sub autoscript {
 428         my $package=shift;
 429         my $script=shift;
 430         my $filename=shift;
 431         my $sed=shift || "";
 432
 433         # This is the file we will modify.
 434         my $outfile="debian/".pkgext($package)."$script.debhelper";
 435
 436         # Figure out what shell script snippet to use.
 437         my $infile;
 438         if (defined($ENV{DH_AUTOSCRIPTDIR}) &&
 439             -e "$ENV{DH_AUTOSCRIPTDIR}/$filename") {
 440                 $infile="$ENV{DH_AUTOSCRIPTDIR}/$filename";
 441         }
 442         else {
 443                 if (-e "/usr/share/debhelper/autoscripts/$filename") {
 444                         $infile="/usr/share/debhelper/autoscripts/$filename";
 445                 }
 446                 else {
 447                         error("/usr/share/debhelper/autoscripts/$filename does not exist");
 448                 }
 449         }
 450
 451         if (-e $outfile && ($script eq 'postrm' || $script eq 'prerm')
 452            && !compat(5)) {
 453                 # Add fragments to top so they run in reverse order when removing.
 454                 complex_doit("echo \"# Automatically added by ".basename($0)."\"> $outfile.new");
 455                 complex_doit("sed \"$sed\" $infile >> $outfile.new");
 456                 complex_doit("echo '# End automatically added section' >> $outfile.new");
 457                 complex_doit("cat $outfile >> $outfile.new");
 458                 complex_doit("mv $outfile.new $outfile");
 459         }
 460         else {
 461                 complex_doit("echo \"# Automatically added by ".basename($0)."\">> $outfile");
 462                 complex_doit("sed \"$sed\" $infile >> $outfile");
 463                 complex_doit("echo '# End automatically added section' >> $outfile");
 464         }
 465 }
 466
 467 # Removes a whole substvar line.
 468 sub delsubstvar {
 469         my $package=shift;
 470         my $substvar=shift;
 471
 472         my $ext=pkgext($package);
 473         my $substvarfile="debian/${ext}substvars";
 474
 475         if (-e $substvarfile) {
 476                 complex_doit("grep -s -v '^${substvar}=' $substvarfile > $substvarfile.new || true");
 477                 doit("mv", "$substvarfile.new","$substvarfile");
 478         }
 479 }
 480
 481 # Adds a dependency on some package to the specified
 482 # substvar in a package's substvar's file.
 483 sub addsubstvar {
 484         my $package=shift;
 485         my $substvar=shift;
 486         my $deppackage=shift;
 487         my $verinfo=shift;
 488         my $remove=shift;
 489
 490         my $ext=pkgext($package);
 491         my $substvarfile="debian/${ext}substvars";
 492         my $str=$deppackage;
 493         $str.=" ($verinfo)" if defined $verinfo && length $verinfo;
 494
 495         # Figure out what the line will look like, based on what's there
 496         # now, and what we're to add or remove.
 497         my $line="";
 498         if (-e $substvarfile) {
 499                 my %items;
 500                 open(SUBSTVARS_IN, "$substvarfile") || error "read $substvarfile: $!";
 501                 while (<SUBSTVARS_IN>) {
 502                         chomp;
 503                         if (/^\Q$substvar\E=(.*)/) {
 504                                 %items = map { $_ => 1} split(", ", $1);
 505
 506                                 last;
 507                         }
 508                 }
 509                 close SUBSTVARS_IN;
 510                 if (! $remove) {
 511                         $items{$str}=1;
 512                 }
 513                 else {
 514                         delete $items{$str};
 515                 }
 516                 $line=join(", ", sort keys %items);
 517         }
 518         elsif (! $remove) {
 519                 $line=$str;
 520         }
 521
 522         if (length $line) {
 523                  complex_doit("(grep -s -v ${substvar} $substvarfile; echo ".escape_shell("${substvar}=$line").") > $substvarfile.new");
 524                  doit("mv", "$substvarfile.new", $substvarfile);
 525         }
 526         else {
 527                 delsubstvar($package,$substvar);
 528         }
 529 }
 530
 531 # Reads in the specified file, one line at a time. splits on words,
 532 # and returns an array of arrays of the contents.
 533 # If a value is passed in as the second parameter, then glob
 534 # expansion is done in the directory specified by the parameter ("." is
 535 # frequently a good choice).
 536 sub filedoublearray {
 537         my $file=shift;
 538         my $globdir=shift;
 539
 540         my @ret;
 541         open (DH_FARRAY_IN, $file) || error("cannot read $file: $1");
 542         while (<DH_FARRAY_IN>) {
 543                 chomp;
 544                 # Only ignore comments and empty lines in v5 mode.
 545                 if (! compat(4)) {
 546                         next if /^#/ || /^$/;
 547                 }
 548                 my @line;
 549                 # Only do glob expansion in v3 mode.
 550                 #
 551                 # The tricky bit is that the glob expansion is done
 552                 # as if we were in the specified directory, so the
 553                 # filenames that come out are relative to it.
 554                 if (defined $globdir && ! compat(2)) {
 555                         for (map { glob "$globdir/$_" } split) {
 556                                 s#^$globdir/##;
 557                                 push @line, $_;
 558                         }
 559                 }
 560                 else {
 561                         @line = split;
 562                 }
 563                 push @ret, [@line];
 564         }
 565         close DH_FARRAY_IN;
 566
 567         return @ret;
 568 }
 569
 570 # Reads in the specified file, one word at a time, and returns an array of
 571 # the result. Can do globbing as does filedoublearray.
 572 sub filearray {
 573         return map { @$_ } filedoublearray(@_);
 574 }
 575
 576 # Passed a filename, returns true if -X says that file should be excluded.
 577 sub excludefile {
 578         my $filename = shift;
 579         foreach my $f (@{$dh{EXCLUDE}}) {
 580                 return 1 if $filename =~ /\Q$f\E/;
 581         }
 582         return 0;
 583 }
 584
 585 # Returns the build architecture. (Memoized)
 586 {
 587         my $arch;
 588
 589         sub buildarch {
 590                 return $arch if defined $arch;
 591
 592                 $arch=`dpkg-architecture -qDEB_HOST_ARCH 2>/dev/null` || error("dpkg-architecture failed");
 593                 chomp $arch;
 594                 return $arch;
 595         }
 596 }
 597
 598 # Passed an arch and a list of arches to match against, returns true if matched
 599 sub samearch {
 600         my $arch=shift;
 601         my @archlist=split(/\s+/,shift);
 602
 603         foreach my $a (@archlist) {
 604                 system("dpkg-architecture", "-a$arch", "-i$a") == 0 && return 1;
 605         }
 606
 607         return 0;
 608 }
 609
 610 # Returns a list of packages in the control file.
 611 # Must pass "arch" or "indep" or "same" to specify arch-dependant or
 612 # -independant or same arch packages. If nothing is specified, returns all
 613 # packages.
 614 # As a side effect, populates %package_arches and %package_types with the
 615 # types of all packages (not only those returned).
 616 my (%package_types, %package_arches);
 617 sub getpackages {
 618         my $type=shift;
 619
 620         %package_types=();
 621         %package_arches=();
 622
 623         $type="" if ! defined $type;
 624
 625         # Look up the build arch if we need to.
 626         my $buildarch='';
 627         if ($type eq 'same') {
 628                 $buildarch=buildarch();
 629         }
 630
 631         my $package="";
 632         my $arch="";
 633         my $package_type;
 634         my @list=();
 635         my %seen;
 636         open (CONTROL, 'debian/control') ||
 637                 error("cannot read debian/control: $!\n");
 638         while (<CONTROL>) {
 639                 chomp;
 640                 s/\s+$//;
 641                 if (/^Package:\s*(.*)/) {
 642                         $package=$1;
 643                         # Detect duplicate package names in the same control file.
 644                         if (! $seen{$package}) {
 645                                 $seen{$package}=1;
 646                         }
 647                         else {
 648                                 error("debian/control has a duplicate entry for $package");
 649                         }
 650                         $package_type="deb";
 651                 }
 652                 if (/^Architecture:\s*(.*)/) {
 653                         $arch=$1;
 654                 }
 655                 if (/^(?:X[BC]*-)?Package-Type:\s*(.*)/) {
 656                         $package_type=$1;
 657                 }
 658
 659                 if (!$_ or eof) { # end of stanza.
 660                         if ($package) {
 661                                 $package_types{$package}=$package_type;
 662                                 $package_arches{$package}=$arch;
 663                         }
 664                         if ($package &&
 665                             (($type eq 'indep' && $arch eq 'all') ||
 666                              ($type eq 'arch' && $arch ne 'all') ||
 667                              ($type eq 'same' && ($arch eq 'any' || samearch($buildarch, $arch))) ||
 668                              ! $type)) {
 669                                 push @list, $package;
 670                                 $package="";
 671                                 $arch="";
 672                         }
 673                 }
 674         }
 675         close CONTROL;
 676
 677         return @list;
 678 }
 679
 680 # Returns the arch a package will build for.
 681 sub package_arch {
 682         my $package=shift;
 683
 684         if (! exists $package_arches{$package}) {
 685                 warning "package $package is not in control info";
 686                 return buildarch();
 687         }
 688         return $package_arches{$package} eq 'all' ? "all" : buildarch();
 689 }
 690
 691 # Return true if a given package is really a udeb.
 692 sub is_udeb {
 693         my $package=shift;
 694
 695         if (! exists $package_types{$package}) {
 696                 warning "package $package is not in control info";
 697                 return 0;
 698         }
 699         return $package_types{$package} eq 'udeb';
 700 }
 701
 702 # Generates the filename that is used for a udeb package.
 703 sub udeb_filename {
 704         my $package=shift;
 705
 706         my $filearch=package_arch($package);
 707         isnative($package); # side effect
 708         my $version=$dh{VERSION};
 709         $version=~s/^[0-9]+://; # strip any epoch
 710         return "${package}_${version}_$filearch.udeb";
 711 }
 712
 713 # Handles #DEBHELPER# substitution in a script; also can generate a new
 714 # script from scratch if none exists but there is a .debhelper file for it.
 715 sub debhelper_script_subst {
 716         my $package=shift;
 717         my $script=shift;
 718
 719         my $tmp=tmpdir($package);
 720         my $ext=pkgext($package);
 721         my $file=pkgfile($package,$script);
 722
 723         if ($file ne '') {
 724                 if (-f "debian/$ext$script.debhelper") {
 725                         # Add this into the script, where it has #DEBHELPER#
 726                         complex_doit("perl -pe 's~#DEBHELPER#~qx{cat debian/$ext$script.debhelper}~eg' < $file > $tmp/DEBIAN/$script");
 727                 }
 728                 else {
 729                         # Just get rid of any #DEBHELPER# in the script.
 730                         complex_doit("sed s/#DEBHELPER#// < $file > $tmp/DEBIAN/$script");
 731                 }
 732                 doit("chown","0:0","$tmp/DEBIAN/$script");
 733                 doit("chmod",755,"$tmp/DEBIAN/$script");
 734         }
 735         elsif ( -f "debian/$ext$script.debhelper" ) {
 736                 complex_doit("printf '#!/bin/sh\nset -e\n' > $tmp/DEBIAN/$script");
 737                 complex_doit("cat debian/$ext$script.debhelper >> $tmp/DEBIAN/$script");
 738                 doit("chown","0:0","$tmp/DEBIAN/$script");
 739                 doit("chmod",755,"$tmp/DEBIAN/$script");
 740         }
 741 }
 742
 743 1