chiark - git - mdw - dpkg/blob - scripts/Dpkg/Source/Package/V3/Bzr.pm

   1 #
   2 # bzr support for dpkg-source
   3 #
   4 # Copyright © 2007 Colin Watson <cjwatson@debian.org>.
   5 # Based on Dpkg::Source::Package::V3_0::git, which is:
   6 # Copyright © 2007 Joey Hess <joeyh@debian.org>.
   7 # Copyright © 2008 Frank Lichtenheld <djpig@debian.org>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 package Dpkg::Source::Package::V3::Bzr;
  23
  24 use strict;
  25 use warnings;
  26
  27 our $VERSION = '0.01';
  28
  29 use Cwd;
  30 use File::Basename;
  31 use File::Find;
  32 use File::Temp qw(tempdir);
  33
  34 use Dpkg::Gettext;
  35 use Dpkg::Compression;
  36 use Dpkg::ErrorHandling;
  37 use Dpkg::Source::Archive;
  38 use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
  39 use Dpkg::Source::Functions qw(erasedir);
  40
  41 use parent qw(Dpkg::Source::Package);
  42
  43 our $CURRENT_MINOR_VERSION = '0';
  44
  45 sub import {
  46     foreach my $dir (split(/:/, $ENV{PATH})) {
  47         if (-x "$dir/bzr") {
  48             return 1;
  49         }
  50     }
  51     error(g_('cannot unpack bzr-format source package because ' .
  52              'bzr is not in the PATH'));
  53 }
  54
  55 sub _sanity_check {
  56     my $srcdir = shift;
  57
  58     if (! -d "$srcdir/.bzr") {
  59         error(g_('source directory is not the top directory of a bzr repository (%s/.bzr not present), but Format bzr was specified'),
  60               $srcdir);
  61     }
  62
  63     # Symlinks from .bzr to outside could cause unpack failures, or
  64     # point to files they shouldn't, so check for and don't allow.
  65     if (-l "$srcdir/.bzr") {
  66         error(g_('%s is a symlink'), "$srcdir/.bzr");
  67     }
  68     my $abs_srcdir = Cwd::abs_path($srcdir);
  69     find(sub {
  70         if (-l) {
  71             if (Cwd::abs_path(readlink) !~ /^\Q$abs_srcdir\E(?:\/|$)/) {
  72                 error(g_('%s is a symlink to outside %s'),
  73                       $File::Find::name, $srcdir);
  74             }
  75         }
  76     }, "$srcdir/.bzr");
  77
  78     return 1;
  79 }
  80
  81 sub can_build {
  82     my ($self, $dir) = @_;
  83
  84     return (0, g_("doesn't contain a bzr repository")) unless -d "$dir/.bzr";
  85     return 1;
  86 }
  87
  88 sub do_build {
  89     my ($self, $dir) = @_;
  90     my @argv = @{$self->{options}{ARGV}};
  91     # TODO: warn here?
  92     #my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}};
  93     my $diff_ignore_regex = $self->{options}{diff_ignore_regex};
  94
  95     $dir =~ s{/+$}{}; # Strip trailing /
  96     my ($dirname, $updir) = fileparse($dir);
  97
  98     if (scalar(@argv)) {
  99         usageerr(g_("-b takes only one parameter with format '%s'"),
 100                  $self->{fields}{'Format'});
 101     }
 102
 103     my $sourcepackage = $self->{fields}{'Source'};
 104     my $basenamerev = $self->get_basename(1);
 105     my $basename = $self->get_basename();
 106     my $basedirname = $basename;
 107     $basedirname =~ s/_/-/;
 108
 109     _sanity_check($dir);
 110
 111     my $old_cwd = getcwd();
 112     chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir);
 113
 114     local $_;
 115
 116     # Check for uncommitted files.
 117     # To support dpkg-source -i, remove any ignored files from the
 118     # output of bzr status.
 119     open(my $bzr_status_fh, '-|', 'bzr', 'status')
 120         or subprocerr('bzr status');
 121     my @files;
 122     while (<$bzr_status_fh>) {
 123         chomp;
 124         next unless s/^ +//;
 125         if (! length $diff_ignore_regex ||
 126             ! m/$diff_ignore_regex/o) {
 127             push @files, $_;
 128         }
 129     }
 130     close($bzr_status_fh) or syserr(g_('bzr status exited nonzero'));
 131     if (@files) {
 132         error(g_('uncommitted, not-ignored changes in working directory: %s'),
 133               join(' ', @files));
 134     }
 135
 136     chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd);
 137
 138     my $tmp = tempdir("$dirname.bzr.XXXXXX", DIR => $updir);
 139     push_exit_handler(sub { erasedir($tmp) });
 140     my $tardir = "$tmp/$dirname";
 141
 142     system('bzr', 'branch', $dir, $tardir);
 143     subprocerr("bzr branch $dir $tardir") if $?;
 144
 145     # Remove the working tree.
 146     system('bzr', 'remove-tree', $tardir);
 147     subprocerr("bzr remove-tree $tardir") if $?;
 148
 149     # Some branch metadata files are unhelpful.
 150     unlink("$tardir/.bzr/branch/branch-name",
 151            "$tardir/.bzr/branch/parent");
 152
 153     # Create the tar file
 154     my $debianfile = "$basenamerev.bzr.tar." . $self->{options}{comp_ext};
 155     info(g_('building %s in %s'),
 156          $sourcepackage, $debianfile);
 157     my $tar = Dpkg::Source::Archive->new(filename => $debianfile,
 158                                          compression => $self->{options}{compression},
 159                                          compression_level => $self->{options}{comp_level});
 160     $tar->create(chdir => $tmp);
 161     $tar->add_directory($dirname);
 162     $tar->finish();
 163
 164     erasedir($tmp);
 165     pop_exit_handler();
 166
 167     $self->add_file($debianfile);
 168 }
 169
 170 # Called after a tarball is unpacked, to check out the working copy.
 171 sub do_extract {
 172     my ($self, $newdirectory) = @_;
 173     my $fields = $self->{fields};
 174
 175     my $dscdir = $self->{basedir};
 176
 177     my $basename = $self->get_basename();
 178     my $basenamerev = $self->get_basename(1);
 179
 180     my @files = $self->get_files();
 181     if (@files > 1) {
 182         error(g_('format v3.0 uses only one source file'));
 183     }
 184     my $tarfile = $files[0];
 185     my $comp_ext_regex = compression_get_file_extension_regex();
 186     if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_ext_regex$/) {
 187         error(g_('expected %s, got %s'),
 188               "$basenamerev.bzr.tar.$comp_ext_regex", $tarfile);
 189     }
 190
 191     if ($self->{options}{no_overwrite_dir} and -e $newdirectory) {
 192         error(g_('unpack target exists: %s'), $newdirectory);
 193     } else {
 194         erasedir($newdirectory);
 195     }
 196
 197     # Extract main tarball
 198     info(g_('unpacking %s'), $tarfile);
 199     my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
 200     $tar->extract($newdirectory);
 201
 202     _sanity_check($newdirectory);
 203
 204     my $old_cwd = getcwd();
 205     chdir($newdirectory)
 206         or syserr(g_("unable to chdir to '%s'"), $newdirectory);
 207
 208     # Reconstitute the working tree.
 209     system('bzr', 'checkout');
 210     subprocerr('bzr checkout') if $?;
 211
 212     chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd);
 213 }
 214
 215 1;