Bzr.pm 6.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216
  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. package Dpkg::Source::Package::V3::Bzr;
  22. use strict;
  23. use warnings;
  24. our $VERSION = '0.01';
  25. use Cwd;
  26. use File::Basename;
  27. use File::Find;
  28. use File::Temp qw(tempdir);
  29. use Dpkg::Gettext;
  30. use Dpkg::Compression;
  31. use Dpkg::ErrorHandling;
  32. use Dpkg::Source::Archive;
  33. use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
  34. use Dpkg::Source::Functions qw(erasedir);
  35. use parent qw(Dpkg::Source::Package);
  36. our $CURRENT_MINOR_VERSION = '0';
  37. sub import {
  38. foreach my $dir (split(/:/, $ENV{PATH})) {
  39. if (-x "$dir/bzr") {
  40. return 1;
  41. }
  42. }
  43. error(g_('cannot unpack bzr-format source package because ' .
  44. 'bzr is not in the PATH'));
  45. }
  46. sub _sanity_check {
  47. my $srcdir = shift;
  48. if (! -d "$srcdir/.bzr") {
  49. error(g_('source directory is not the top directory of a bzr repository (%s/.bzr not present), but Format bzr was specified'),
  50. $srcdir);
  51. }
  52. # Symlinks from .bzr to outside could cause unpack failures, or
  53. # point to files they shouldn't, so check for and don't allow.
  54. if (-l "$srcdir/.bzr") {
  55. error(g_('%s is a symlink'), "$srcdir/.bzr");
  56. }
  57. my $abs_srcdir = Cwd::abs_path($srcdir);
  58. find(sub {
  59. if (-l) {
  60. if (Cwd::abs_path(readlink) !~ /^\Q$abs_srcdir\E(?:\/|$)/) {
  61. error(g_('%s is a symlink to outside %s'),
  62. $File::Find::name, $srcdir);
  63. }
  64. }
  65. }, "$srcdir/.bzr");
  66. return 1;
  67. }
  68. sub can_build {
  69. my ($self, $dir) = @_;
  70. return (0, g_("doesn't contain a bzr repository")) unless -d "$dir/.bzr";
  71. return 1;
  72. }
  73. sub do_build {
  74. my ($self, $dir) = @_;
  75. my @argv = @{$self->{options}{ARGV}};
  76. # TODO: warn here?
  77. #my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}};
  78. my $diff_ignore_regex = $self->{options}{diff_ignore_regex};
  79. $dir =~ s{/+$}{}; # Strip trailing /
  80. my ($dirname, $updir) = fileparse($dir);
  81. if (scalar(@argv)) {
  82. usageerr(g_("-b takes only one parameter with format '%s'"),
  83. $self->{fields}{'Format'});
  84. }
  85. my $sourcepackage = $self->{fields}{'Source'};
  86. my $basenamerev = $self->get_basename(1);
  87. my $basename = $self->get_basename();
  88. my $basedirname = $basename;
  89. $basedirname =~ s/_/-/;
  90. _sanity_check($dir);
  91. my $old_cwd = getcwd();
  92. chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir);
  93. local $_;
  94. # Check for uncommitted files.
  95. # To support dpkg-source -i, remove any ignored files from the
  96. # output of bzr status.
  97. open(my $bzr_status_fh, '-|', 'bzr', 'status')
  98. or subprocerr('bzr status');
  99. my @files;
  100. while (<$bzr_status_fh>) {
  101. chomp;
  102. next unless s/^ +//;
  103. if (! length $diff_ignore_regex ||
  104. ! m/$diff_ignore_regex/o) {
  105. push @files, $_;
  106. }
  107. }
  108. close($bzr_status_fh) or syserr(g_('bzr status exited nonzero'));
  109. if (@files) {
  110. error(g_('uncommitted, not-ignored changes in working directory: %s'),
  111. join(' ', @files));
  112. }
  113. chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd);
  114. my $tmp = tempdir("$dirname.bzr.XXXXXX", DIR => $updir);
  115. push_exit_handler(sub { erasedir($tmp) });
  116. my $tardir = "$tmp/$dirname";
  117. system('bzr', 'branch', $dir, $tardir);
  118. subprocerr("bzr branch $dir $tardir") if $?;
  119. # Remove the working tree.
  120. system('bzr', 'remove-tree', $tardir);
  121. subprocerr("bzr remove-tree $tardir") if $?;
  122. # Some branch metadata files are unhelpful.
  123. unlink("$tardir/.bzr/branch/branch-name",
  124. "$tardir/.bzr/branch/parent");
  125. # Create the tar file
  126. my $debianfile = "$basenamerev.bzr.tar." . $self->{options}{comp_ext};
  127. info(g_('building %s in %s'),
  128. $sourcepackage, $debianfile);
  129. my $tar = Dpkg::Source::Archive->new(filename => $debianfile,
  130. compression => $self->{options}{compression},
  131. compression_level => $self->{options}{comp_level});
  132. $tar->create(chdir => $tmp);
  133. $tar->add_directory($dirname);
  134. $tar->finish();
  135. erasedir($tmp);
  136. pop_exit_handler();
  137. $self->add_file($debianfile);
  138. }
  139. # Called after a tarball is unpacked, to check out the working copy.
  140. sub do_extract {
  141. my ($self, $newdirectory) = @_;
  142. my $fields = $self->{fields};
  143. my $dscdir = $self->{basedir};
  144. my $basename = $self->get_basename();
  145. my $basenamerev = $self->get_basename(1);
  146. my @files = $self->get_files();
  147. if (@files > 1) {
  148. error(g_('format v3.0 uses only one source file'));
  149. }
  150. my $tarfile = $files[0];
  151. my $comp_ext_regex = compression_get_file_extension_regex();
  152. if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_ext_regex$/) {
  153. error(g_('expected %s, got %s'),
  154. "$basenamerev.bzr.tar.$comp_ext_regex", $tarfile);
  155. }
  156. if ($self->{options}{no_overwrite_dir} and -e $newdirectory) {
  157. error(g_('unpack target exists: %s'), $newdirectory);
  158. } else {
  159. erasedir($newdirectory);
  160. }
  161. # Extract main tarball
  162. info(g_('unpacking %s'), $tarfile);
  163. my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
  164. $tar->extract($newdirectory);
  165. _sanity_check($newdirectory);
  166. my $old_cwd = getcwd();
  167. chdir($newdirectory)
  168. or syserr(g_("unable to chdir to '%s'"), $newdirectory);
  169. # Reconstitute the working tree.
  170. system('bzr', 'checkout');
  171. subprocerr('bzr checkout') if $?;
  172. chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd);
  173. }
  174. 1;