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