Commit | Line | Data |
---|---|---|
1479465f GJ |
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; |