Dh_Lib.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # Library functions for debhelper programs, perl version.
   4 #
   5 # Joey Hess, GPL copyright 1997, 1998.
   6
   7 package Dh_Lib;
   8
   9 use Exporter;
  10 use vars qw(%dh);
  11 @ISA=qw(Exporter);
  12 @EXPORT=qw(&init &doit &complex_doit &verbose_print &error &warning &tmpdir
  13             &pkgfile &pkgext &isnative &autoscript &filearray &GetPackages
  14             %dh);
  15
  16 sub init {
  17         # Check to see if an argument on the command line starts with a dash.
  18         # if so, we need to pass this off to the resource intensive Getopt::Long,
  19         # which I'd prefer to avoid loading at all if possible.
  20         my $parseopt=undef;
  21         foreach $arg (@ARGV) {
  22                 if ($arg=~m/^-/) {
  23                         $parseopt=1;
  24                         last;
  25                 }
  26         }
  27         if ($parseopt) {
  28                 eval "use Dh_Getopt";
  29                 error($!) if $@;
  30                 %dh=Dh_Getopt::parseopts();
  31         }
  32
  33         # Get the name of the main binary package (first one listed in
  34         # debian/control).
  35         my @allpackages=GetPackages();
  36         $dh{MAINPACKAGE}=$allpackages[0];
  37
  38         # Check if packages to build have been specified, if not, fall back to
  39         # the default, doing them all.
  40         if (! @{$dh{DOPACKAGES}}) {
  41                 if ($dh{DH_DOINDEP} || $dh{DH_DOARCH}) {
  42                         error("I have no package to build.");
  43                 }
  44                 push @{$dh{DOPACKAGES}},@allpackages;
  45         }
  46
  47         # Check to see if -P was specified. If so, we can only act on a single
  48         # package.
  49         if ($dh{TMPDIR} || $#{$dh{DOPACKAGES}} > 0) {
  50                 error("-P was specified, but multiple packages would be acted on.");
  51         }
  52
  53         # Figure out which package is the first one we were instructed to build.
  54         # This package gets special treatement: files and directories specified on
  55         # the command line may affect it.
  56         $dh{FIRSTPACKAGE}=${$dh{DOPACKAGES}}[0];
  57 }
  58
  59 # Run a command, and display the command to stdout if verbose mode is on.
  60 # All commands that modifiy files in $TMP should be ran via this
  61 # function.
  62 #
  63 # Note that this cannot handle complex commands, especially anything
  64 # involving redirection. Use complex_doit instead.
  65 sub doit {
  66         verbose_print(join(" ",,@_));
  67
  68         if (! $dh{NO_ACT}) {
  69                 system(@_) == 0
  70                         || error("command returned error code");
  71
  72         }
  73 }
  74
  75 # This is an identical command to doit, except the parameters passed to it
  76 # can include complex shell stull like redirection and compound commands.
  77 sub complex_doit {
  78         error("complex_doit() not yet supported");
  79 }
  80
  81 # Print something if the verbose flag is on.
  82 sub verbose_print { my $message=shift;
  83         if ($dh{VERBOSE}) {
  84                 print "\t$message\n";
  85         }
  86 }
  87
  88 # Output an error message and exit.
  89 sub error { my $message=shift;
  90         warning($message);
  91         exit 1;
  92 }
  93
  94 # Output a warning.
  95 sub warning { my $message=shift;
  96         my $fn=$0;
  97         $fn=~s:.*/(.*?):$1:;
  98         print STDERR "$fn: $message\n";
  99 }
 100
 101 # Pass it a name of a binary package, it returns the name of the tmp dir to
 102 # use, for that package.
 103 # This is for back-compatability with the debian/tmp tradition.
 104 sub tmpdir { my $package=shift;
 105         if ($dh{TMPDIR}) {
 106                 return $dh{TMPDIR};
 107         }
 108         elsif ($package eq $dh{MAINPACKAGE}) {
 109                 return "debian/tmp";
 110         }
 111         else {
 112                 return "debian/$package";
 113         }
 114 }
 115
 116 # Pass this the name of a binary package, and the name of the file wanted
 117 # for the package, and it will return the actual filename to use. For
 118 # example if the package is foo, and the file is somefile, it will look for
 119 # debian/somefile, and if found return that, otherwise, if the package is
 120 # the main package, it will look for debian/foo, and if found, return that.
 121 # Failing that, it will return nothing.
 122 sub pkgfile { my $package=shift; my $filename=shift;
 123         if (-e "debian/$package.$filename") {
 124                 return "debian/$package.$filename";
 125         }
 126         elsif ($package eq $dh{MAINPACKAGE} && -e "debian/$filename") {
 127                 return "debian/$filename";
 128         }
 129         return "";
 130 }
 131
 132 # Pass it a name of a binary package, it returns the name to prefix to files
 133 # in debian for this package.
 134 sub pkgext { my $package=shift;
 135         if ($package ne $MAINPACKAGE) {
 136                 return "$package.";
 137         }
 138         return "";
 139 }
 140
 141 # Returns 1 if the package is a native debian package, null otherwise.
 142 # As a side effect, sets $dh{VERSION} to the version of this package.
 143 {
 144         # Caches return code so it only needs to run dpkg-parsechangelog once.
 145         my $isnative_cache;
 146
 147         sub isnative { my $package=shift;
 148                 if ($isnative_cache eq undef) {
 149                         # Make sure we look at the correct changelog.
 150                         my $isnative_changelog=pkgfile($package,"changelog");
 151                         if (! $isnative_changelog) {
 152                                 $isnative_changelog="debian/changelog";
 153                         }
 154
 155                         # Get the package version.
 156                         my $version=`dpkg-parsechangelog -l$isnative_changelog`;
 157                         ($dh{VERSION})=$version=~s/[^|\n]Version: \(.*\)\n//m;
 158
 159                         # Is this a native Debian package?
 160                         if ($dh{VERSION}=~m/.*-/) {
 161                                 $isnative_cache=1;
 162                         }
 163                         else {
 164                                 $isnative_cache=0;
 165                         }
 166                 }
 167
 168                 return $isnative_cache;
 169         }
 170 }
 171
 172 # Automatically add a shell script snippet to a debian script.
 173 # Only works if the script has #DEBHELPER# in it.
 174 #
 175 # Parameters:
 176 # 1: script to add to
 177 # 2: filename of snippet
 178 # 3: sed commands to run on the snippet. Ie, s/#PACKAGE#/$PACKAGE/
 179 sub autoscript {
 180         error "autoscript() not yet implemented (lazy, lazy!)";
 181 #       autoscript_script=$1
 182 #       autoscript_filename=$2
 183 #       autoscript_sed=$3
 184 #       autoscript_debscript=debian/`pkgext $PACKAGE`$autoscript_script.debhelper
 185 #
 186 #       if [ -e "$DH_AUTOSCRIPTDIR/$autoscript_filename" ]; then
 187 #               autoscript_filename="$DH_AUTOSCRIPTDIR/$autoscript_filename"
 188 #       else
 189 #               if [ -e "/usr/lib/debhelper/autoscripts/$autoscript_filename" ]; then
 190 #                       autoscript_filename="/usr/lib/debhelper/autoscripts/$autoscript_filename"
 191 #               else
 192 #                       error "/usr/lib/debhelper/autoscripts/$autoscript_filename does not exist"
 193 #               fi
 194 #       fi
 195 #
 196 #       complex_doit "echo \"# Automatically added by `basename $0`\" >> $autoscript_debscript"
 197 #       complex_doit "sed \"$autoscript_sed\" $autoscript_filename >> $autoscript_debscript"
 198 #       complex_doit "echo '# End automatically added section' >> $autoscript_debscript"
 199 }
 200
 201 # Reads in the specified file, one word at a time, and returns an array of
 202 # the result.
 203 sub filearray { $file=shift;
 204         my @ret;
 205         open (DH_FARRAY_IN,"<$file") || error("cannot read $file: $1");
 206         while (<DH_FARRAY_IN>) {
 207                 push @ret,split(/\s/,$_);
 208         }
 209         close DH_ARRAY;
 210
 211         return @ret;
 212 }
 213
 214 # Returns a list of packages in the control file.
 215 # Must pass "arch" or "indep" to specify arch-dependant or -independant
 216 # packages. If nothing is specified, returns all packages.
 217 sub GetPackages { $type=shift;
 218         my $package;
 219         my $arch;
 220         my @list;
 221         open (CONTROL,"<debian/control") ||
 222                 error("cannot read debian/control: $!\n");
 223         while (<CONTROL>) {
 224                 chomp;
 225                 s/\s+$//;
 226                 if (/^Package:\s+(.*)/) {
 227                         $package=$1;
 228                 }
 229                 if (/^Architecture:\s+(.*)/) {
 230                         $arch=$1;
 231                 }
 232                 if (!$_ or eof) { # end of stanza.
 233                         if ($package &&
 234                             (($type eq 'indep' && $arch eq 'all') ||
 235                              ($type eq 'arch' && $arch ne 'all') ||
 236                              ! $type)) {
 237                                 push @list, $package;
 238                                 undef $package;
 239                                 undef $arch;
 240                         }
 241                 }
 242         }
 243         close CONTROL;
 244
 245         return @list;
 246 }
 247
 248 1