Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> |
2 | # Copyright © 2008-2015 Guillem Jover <guillem@debian.org> | |
3 | # | |
4 | # This program is free software; you can redistribute it and/or modify | |
5 | # it under the terms of the GNU General Public License as published by | |
6 | # the Free Software Foundation; either version 2 of the License, or | |
7 | # (at your option) any later version. | |
8 | # | |
9 | # This program is distributed in the hope that it will be useful, | |
10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | # GNU General Public License for more details. | |
13 | # | |
14 | # You should have received a copy of the GNU General Public License | |
15 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
16 | ||
17 | package Dpkg::Source::Package; | |
18 | ||
19 | =encoding utf8 | |
20 | ||
21 | =head1 NAME | |
22 | ||
23 | Dpkg::Source::Package - manipulate Debian source packages | |
24 | ||
25 | =head1 DESCRIPTION | |
26 | ||
27 | This module provides an object that can manipulate Debian source | |
28 | packages. While it supports both the extraction and the creation | |
29 | of source packages, the only API that is officially supported | |
30 | is the one that supports the extraction of the source package. | |
31 | ||
32 | =cut | |
33 | ||
34 | use strict; | |
35 | use warnings; | |
36 | ||
37 | our $VERSION = '1.02'; | |
38 | our @EXPORT_OK = qw( | |
39 | get_default_diff_ignore_regex | |
40 | set_default_diff_ignore_regex | |
41 | get_default_tar_ignore_pattern | |
42 | ); | |
43 | ||
44 | use Exporter qw(import); | |
45 | use POSIX qw(:errno_h :sys_wait_h); | |
46 | use Carp; | |
47 | use File::Basename; | |
48 | ||
49 | use Dpkg::Gettext; | |
50 | use Dpkg::ErrorHandling; | |
51 | use Dpkg::Control; | |
52 | use Dpkg::Checksums; | |
53 | use Dpkg::Version; | |
54 | use Dpkg::Compression; | |
55 | use Dpkg::Exit qw(run_exit_handlers); | |
56 | use Dpkg::Path qw(check_files_are_the_same find_command); | |
57 | use Dpkg::IPC; | |
58 | use Dpkg::Vendor qw(run_vendor_hook); | |
59 | ||
60 | my $diff_ignore_default_regex = ' | |
61 | # Ignore general backup files | |
62 | (?:^|/).*~$| | |
63 | # Ignore emacs recovery files | |
64 | (?:^|/)\.#.*$| | |
65 | # Ignore vi swap files | |
66 | (?:^|/)\..*\.sw.$| | |
67 | # Ignore baz-style junk files or directories | |
68 | (?:^|/),,.*(?:$|/.*$)| | |
69 | # File-names that should be ignored (never directories) | |
70 | (?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$| | |
71 | # File or directory names that should be ignored | |
72 | (?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn| | |
73 | \.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?| | |
74 | \.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$) | |
75 | '; | |
76 | # Take out comments and newlines | |
77 | $diff_ignore_default_regex =~ s/^#.*$//mg; | |
78 | $diff_ignore_default_regex =~ s/\n//sg; | |
79 | ||
80 | # Public variables | |
81 | # XXX: Backwards compatibility, stop exporting on VERSION 2.00. | |
82 | ## no critic (Variables::ProhibitPackageVars) | |
83 | our $diff_ignore_default_regexp; | |
84 | *diff_ignore_default_regexp = \$diff_ignore_default_regex; | |
85 | ||
86 | no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings) | |
87 | our @tar_ignore_default_pattern = qw( | |
88 | *.a | |
89 | *.la | |
90 | *.o | |
91 | *.so | |
92 | .*.sw? | |
93 | */*~ | |
94 | ,,* | |
95 | .[#~]* | |
96 | .arch-ids | |
97 | .arch-inventory | |
98 | .be | |
99 | .bzr | |
100 | .bzr.backup | |
101 | .bzr.tags | |
102 | .bzrignore | |
103 | .cvsignore | |
104 | .deps | |
105 | .git | |
106 | .gitattributes | |
107 | .gitignore | |
108 | .gitmodules | |
109 | .gitreview | |
110 | .hg | |
111 | .hgignore | |
112 | .hgsigs | |
113 | .hgtags | |
114 | .mailmap | |
115 | .mtn-ignore | |
116 | .shelf | |
117 | .svn | |
118 | CVS | |
119 | DEADJOE | |
120 | RCS | |
121 | _MTN | |
122 | _darcs | |
123 | {arch} | |
124 | ); | |
125 | ## use critic | |
126 | ||
127 | =head1 FUNCTIONS | |
128 | ||
129 | =over 4 | |
130 | ||
131 | =item $string = get_default_diff_ignore_regex() | |
132 | ||
133 | Returns the default diff ignore regex. | |
134 | ||
135 | =cut | |
136 | ||
137 | sub get_default_diff_ignore_regex { | |
138 | return $diff_ignore_default_regex; | |
139 | } | |
140 | ||
141 | =item set_default_diff_ignore_regex($string) | |
142 | ||
143 | Set a regex as the new default diff ignore regex. | |
144 | ||
145 | =cut | |
146 | ||
147 | sub set_default_diff_ignore_regex { | |
148 | my $regex = shift; | |
149 | ||
150 | $diff_ignore_default_regex = $regex; | |
151 | } | |
152 | ||
153 | =item @array = get_default_tar_ignore_pattern() | |
154 | ||
155 | Returns the default tar ignore pattern, as an array. | |
156 | ||
157 | =cut | |
158 | ||
159 | sub get_default_tar_ignore_pattern { | |
160 | return @tar_ignore_default_pattern; | |
161 | } | |
162 | ||
163 | =back | |
164 | ||
165 | =head1 METHODS | |
166 | ||
167 | =over 4 | |
168 | ||
169 | =item $p = Dpkg::Source::Package->new(filename => $dscfile, options => {}) | |
170 | ||
171 | Creates a new object corresponding to the source package described | |
172 | by the file $dscfile. | |
173 | ||
174 | The options hash supports the following options: | |
175 | ||
176 | =over 8 | |
177 | ||
178 | =item skip_debianization | |
179 | ||
180 | If set to 1, do not apply Debian changes on the extracted source package. | |
181 | ||
182 | =item skip_patches | |
183 | ||
184 | If set to 1, do not apply Debian-specific patches. This options is | |
185 | specific for source packages using format "2.0" and "3.0 (quilt)". | |
186 | ||
187 | =item require_valid_signature | |
188 | ||
189 | If set to 1, the check_signature() method will be stricter and will error | |
190 | out if the signature can't be verified. | |
191 | ||
192 | =item require_strong_checksums | |
193 | ||
194 | If set to 1, the check_checksums() method will be stricter and will error | |
195 | out if there is no strong checksum. | |
196 | ||
197 | =item copy_orig_tarballs | |
198 | ||
199 | If set to 1, the extraction will copy the upstream tarballs next the | |
200 | target directory. This is useful if you want to be able to rebuild the | |
201 | source package after its extraction. | |
202 | ||
203 | =back | |
204 | ||
205 | =cut | |
206 | ||
207 | # Object methods | |
208 | sub new { | |
209 | my ($this, %args) = @_; | |
210 | my $class = ref($this) || $this; | |
211 | my $self = { | |
212 | fields => Dpkg::Control->new(type => CTRL_PKG_SRC), | |
213 | options => {}, | |
214 | checksums => Dpkg::Checksums->new(), | |
215 | }; | |
216 | bless $self, $class; | |
217 | if (exists $args{options}) { | |
218 | $self->{options} = $args{options}; | |
219 | } | |
220 | if (exists $args{filename}) { | |
221 | $self->initialize($args{filename}); | |
222 | $self->init_options(); | |
223 | } | |
224 | return $self; | |
225 | } | |
226 | ||
227 | sub init_options { | |
228 | my $self = shift; | |
229 | # Use full ignore list by default | |
230 | # note: this function is not called by V1 packages | |
231 | $self->{options}{diff_ignore_regex} ||= $diff_ignore_default_regex; | |
232 | $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; | |
233 | $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; | |
234 | if (defined $self->{options}{tar_ignore}) { | |
235 | $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ] | |
236 | unless @{$self->{options}{tar_ignore}}; | |
237 | } else { | |
238 | $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ]; | |
239 | } | |
240 | push @{$self->{options}{tar_ignore}}, | |
241 | 'debian/source/local-options', | |
242 | 'debian/source/local-patch-header', | |
243 | 'debian/files', | |
244 | 'debian/files.new'; | |
245 | # Skip debianization while specific to some formats has an impact | |
246 | # on code common to all formats | |
247 | $self->{options}{skip_debianization} //= 0; | |
248 | ||
249 | # Set default compressor for new formats. | |
250 | $self->{options}{compression} //= 'xz'; | |
251 | $self->{options}{comp_level} //= compression_get_property($self->{options}{compression}, | |
252 | 'default_level'); | |
253 | $self->{options}{comp_ext} //= compression_get_property($self->{options}{compression}, | |
254 | 'file_ext'); | |
255 | } | |
256 | ||
257 | sub initialize { | |
258 | my ($self, $filename) = @_; | |
259 | my ($fn, $dir) = fileparse($filename); | |
260 | error(g_('%s is not the name of a file'), $filename) unless $fn; | |
261 | $self->{basedir} = $dir || './'; | |
262 | $self->{filename} = $fn; | |
263 | ||
264 | # Read the fields | |
265 | my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC); | |
266 | $fields->load($filename); | |
267 | $self->{fields} = $fields; | |
268 | $self->{is_signed} = $fields->get_option('is_pgp_signed'); | |
269 | ||
270 | foreach my $f (qw(Source Version Files)) { | |
271 | unless (defined($fields->{$f})) { | |
272 | error(g_('missing critical source control field %s'), $f); | |
273 | } | |
274 | } | |
275 | ||
276 | $self->{checksums}->add_from_control($fields, use_files_for_md5 => 1); | |
277 | ||
278 | $self->upgrade_object_type(0); | |
279 | } | |
280 | ||
281 | sub upgrade_object_type { | |
282 | my ($self, $update_format) = @_; | |
283 | $update_format //= 1; | |
284 | $self->{fields}{'Format'} //= '1.0'; | |
285 | my $format = $self->{fields}{'Format'}; | |
286 | ||
287 | if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) { | |
288 | my ($version, $variant) = ($1, $2); | |
289 | ||
290 | if (defined $variant and $variant ne lc $variant) { | |
291 | error(g_("source package format '%s' is not supported: %s"), | |
292 | $format, g_('format variant must be in lowercase')); | |
293 | } | |
294 | ||
295 | my $major = $version =~ s/\.[\d\.]+$//r; | |
296 | my $minor; | |
297 | ||
298 | my $module = "Dpkg::Source::Package::V$major"; | |
299 | $module .= '::' . ucfirst $variant if defined $variant; | |
300 | eval qq{ | |
301 | pop \@INC if \$INC[-1] eq '.'; | |
302 | require $module; | |
303 | \$minor = \$${module}::CURRENT_MINOR_VERSION; | |
304 | }; | |
305 | $minor //= 0; | |
306 | if ($update_format) { | |
307 | $self->{fields}{'Format'} = "$major.$minor"; | |
308 | $self->{fields}{'Format'} .= " ($variant)" if defined $variant; | |
309 | } | |
310 | if ($@) { | |
311 | error(g_("source package format '%s' is not supported: %s"), | |
312 | $format, $@); | |
313 | } | |
314 | bless $self, $module; | |
315 | } else { | |
316 | error(g_("invalid Format field '%s'"), $format); | |
317 | } | |
318 | } | |
319 | ||
320 | =item $p->get_filename() | |
321 | ||
322 | Returns the filename of the DSC file. | |
323 | ||
324 | =cut | |
325 | ||
326 | sub get_filename { | |
327 | my $self = shift; | |
328 | return $self->{basedir} . $self->{filename}; | |
329 | } | |
330 | ||
331 | =item $p->get_files() | |
332 | ||
333 | Returns the list of files referenced by the source package. The filenames | |
334 | usually do not have any path information. | |
335 | ||
336 | =cut | |
337 | ||
338 | sub get_files { | |
339 | my $self = shift; | |
340 | return $self->{checksums}->get_files(); | |
341 | } | |
342 | ||
343 | =item $p->check_checksums() | |
344 | ||
345 | Verify the checksums embedded in the DSC file. It requires the presence of | |
346 | the other files constituting the source package. If any inconsistency is | |
347 | discovered, it immediately errors out. It will make sure at least one strong | |
348 | checksum is present. | |
349 | ||
350 | If the object has been created with the "require_strong_checksums" option, | |
351 | then any problem will result in a fatal error. | |
352 | ||
353 | =cut | |
354 | ||
355 | sub check_checksums { | |
356 | my $self = shift; | |
357 | my $checksums = $self->{checksums}; | |
358 | my $warn_on_weak = 0; | |
359 | ||
360 | # add_from_file verify the checksums if they are already existing | |
361 | foreach my $file ($checksums->get_files()) { | |
362 | if (not $checksums->has_strong_checksums($file)) { | |
363 | if ($self->{options}{require_strong_checksums}) { | |
364 | error(g_('source package uses only weak checksums')); | |
365 | } else { | |
366 | $warn_on_weak = 1; | |
367 | } | |
368 | } | |
369 | $checksums->add_from_file($self->{basedir} . $file, key => $file); | |
370 | } | |
371 | ||
372 | warning(g_('source package uses only weak checksums')) if $warn_on_weak; | |
373 | } | |
374 | ||
375 | sub get_basename { | |
376 | my ($self, $with_revision) = @_; | |
377 | my $f = $self->{fields}; | |
378 | unless (exists $f->{'Source'} and exists $f->{'Version'}) { | |
379 | error(g_('%s and %s fields are required to compute the source basename'), | |
380 | 'Source', 'Version'); | |
381 | } | |
382 | my $v = Dpkg::Version->new($f->{'Version'}); | |
383 | my $vs = $v->as_string(omit_epoch => 1, omit_revision => !$with_revision); | |
384 | return $f->{'Source'} . '_' . $vs; | |
385 | } | |
386 | ||
387 | sub find_original_tarballs { | |
388 | my ($self, %opts) = @_; | |
389 | $opts{extension} //= compression_get_file_extension_regex(); | |
390 | $opts{include_main} //= 1; | |
391 | $opts{include_supplementary} //= 1; | |
392 | my $basename = $self->get_basename(); | |
393 | my @tar; | |
394 | foreach my $dir ('.', $self->{basedir}, $self->{options}{origtardir}) { | |
395 | next unless defined($dir) and -d $dir; | |
396 | opendir(my $dir_dh, $dir) or syserr(g_('cannot opendir %s'), $dir); | |
397 | push @tar, map { "$dir/$_" } grep { | |
398 | ($opts{include_main} and | |
399 | /^\Q$basename\E\.orig\.tar\.$opts{extension}$/) or | |
400 | ($opts{include_supplementary} and | |
401 | /^\Q$basename\E\.orig-[[:alnum:]-]+\.tar\.$opts{extension}$/) | |
402 | } readdir($dir_dh); | |
403 | closedir($dir_dh); | |
404 | } | |
405 | return @tar; | |
406 | } | |
407 | ||
408 | =item $bool = $p->is_signed() | |
409 | ||
410 | Returns 1 if the DSC files contains an embedded OpenPGP signature. | |
411 | Otherwise returns 0. | |
412 | ||
413 | =cut | |
414 | ||
415 | sub is_signed { | |
416 | my $self = shift; | |
417 | return $self->{is_signed}; | |
418 | } | |
419 | ||
420 | =item $p->check_signature() | |
421 | ||
422 | Implement the same OpenPGP signature check that dpkg-source does. | |
423 | In case of problems, it prints a warning or errors out. | |
424 | ||
425 | If the object has been created with the "require_valid_signature" option, | |
426 | then any problem will result in a fatal error. | |
427 | ||
428 | =cut | |
429 | ||
430 | sub check_signature { | |
431 | my $self = shift; | |
432 | my $dsc = $self->get_filename(); | |
433 | my @exec; | |
434 | ||
435 | if (find_command('gpgv2')) { | |
436 | push @exec, 'gpgv2'; | |
437 | } elsif (find_command('gpgv')) { | |
438 | push @exec, 'gpgv'; | |
439 | } elsif (find_command('gpg2')) { | |
440 | push @exec, 'gpg2', '--no-default-keyring', '-q', '--verify'; | |
441 | } elsif (find_command('gpg')) { | |
442 | push @exec, 'gpg', '--no-default-keyring', '-q', '--verify'; | |
443 | } | |
444 | if (scalar(@exec)) { | |
445 | if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") { | |
446 | push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg"; | |
447 | } | |
448 | foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) { | |
449 | if (-r $vendor_keyring) { | |
450 | push @exec, '--keyring', $vendor_keyring; | |
451 | } | |
452 | } | |
453 | push @exec, $dsc; | |
454 | ||
455 | my ($stdout, $stderr); | |
456 | spawn(exec => \@exec, wait_child => 1, nocheck => 1, | |
457 | to_string => \$stdout, error_to_string => \$stderr, | |
458 | timeout => 10); | |
459 | if (WIFEXITED($?)) { | |
460 | my $gpg_status = WEXITSTATUS($?); | |
461 | print { *STDERR } "$stdout$stderr" if $gpg_status; | |
462 | if ($gpg_status == 1 or ($gpg_status && | |
463 | $self->{options}{require_valid_signature})) | |
464 | { | |
465 | error(g_('failed to verify signature on %s'), $dsc); | |
466 | } elsif ($gpg_status) { | |
467 | warning(g_('failed to verify signature on %s'), $dsc); | |
468 | } | |
469 | } else { | |
470 | subprocerr("@exec"); | |
471 | } | |
472 | } else { | |
473 | if ($self->{options}{require_valid_signature}) { | |
474 | error(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc); | |
475 | } else { | |
476 | warning(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc); | |
477 | } | |
478 | } | |
479 | } | |
480 | ||
481 | sub describe_cmdline_options { | |
482 | return; | |
483 | } | |
484 | ||
485 | sub parse_cmdline_options { | |
486 | my ($self, @opts) = @_; | |
487 | foreach my $option (@opts) { | |
488 | if (not $self->parse_cmdline_option($option)) { | |
489 | warning(g_('%s is not a valid option for %s'), $option, ref $self); | |
490 | } | |
491 | } | |
492 | } | |
493 | ||
494 | sub parse_cmdline_option { | |
495 | return 0; | |
496 | } | |
497 | ||
498 | =item $p->extract($targetdir) | |
499 | ||
500 | Extracts the source package in the target directory $targetdir. Beware | |
501 | that if $targetdir already exists, it will be erased (as long as the | |
502 | no_overwrite_dir option is set). | |
503 | ||
504 | =cut | |
505 | ||
506 | sub extract { | |
507 | my ($self, $newdirectory) = @_; | |
508 | ||
509 | my ($ok, $error) = version_check($self->{fields}{'Version'}); | |
510 | if (not $ok) { | |
511 | if ($self->{options}{ignore_bad_version}) { | |
512 | warning($error); | |
513 | } else { | |
514 | error($error); | |
515 | } | |
516 | } | |
517 | ||
518 | # Copy orig tarballs | |
519 | if ($self->{options}{copy_orig_tarballs}) { | |
520 | my $basename = $self->get_basename(); | |
521 | my ($dirname, $destdir) = fileparse($newdirectory); | |
522 | $destdir ||= './'; | |
523 | my $ext = compression_get_file_extension_regex(); | |
524 | foreach my $orig (grep { /^\Q$basename\E\.orig(-[[:alnum:]-]+)?\.tar\.$ext$/ } | |
525 | $self->get_files()) | |
526 | { | |
527 | my $src = File::Spec->catfile($self->{basedir}, $orig); | |
528 | my $dst = File::Spec->catfile($destdir, $orig); | |
529 | if (not check_files_are_the_same($src, $dst, 1)) { | |
530 | system('cp', '--', $src, $dst); | |
531 | subprocerr("cp $src to $dst") if $?; | |
532 | } | |
533 | } | |
534 | } | |
535 | ||
536 | # Try extract | |
537 | eval { $self->do_extract($newdirectory) }; | |
538 | if ($@) { | |
539 | run_exit_handlers(); | |
540 | die $@; | |
541 | } | |
542 | ||
543 | # Store format if non-standard so that next build keeps the same format | |
544 | if ($self->{fields}{'Format'} ne '1.0' and | |
545 | not $self->{options}{skip_debianization}) | |
546 | { | |
547 | my $srcdir = File::Spec->catdir($newdirectory, 'debian', 'source'); | |
548 | my $format_file = File::Spec->catfile($srcdir, 'format'); | |
549 | unless (-e $format_file) { | |
550 | mkdir($srcdir) unless -e $srcdir; | |
551 | open(my $format_fh, '>', $format_file) | |
552 | or syserr(g_('cannot write %s'), $format_file); | |
553 | print { $format_fh } $self->{fields}{'Format'} . "\n"; | |
554 | close($format_fh); | |
555 | } | |
556 | } | |
557 | ||
558 | # Make sure debian/rules is executable | |
559 | my $rules = File::Spec->catfile($newdirectory, 'debian', 'rules'); | |
560 | my @s = lstat($rules); | |
561 | if (not scalar(@s)) { | |
562 | unless ($! == ENOENT) { | |
563 | syserr(g_('cannot stat %s'), $rules); | |
564 | } | |
565 | warning(g_('%s does not exist'), $rules) | |
566 | unless $self->{options}{skip_debianization}; | |
567 | } elsif (-f _) { | |
568 | chmod($s[2] | 0111, $rules) | |
569 | or syserr(g_('cannot make %s executable'), $rules); | |
570 | } else { | |
571 | warning(g_('%s is not a plain file'), $rules); | |
572 | } | |
573 | } | |
574 | ||
575 | sub do_extract { | |
576 | croak 'Dpkg::Source::Package does not know how to unpack a ' . | |
577 | 'source package; use one of the subclasses'; | |
578 | } | |
579 | ||
580 | # Function used specifically during creation of a source package | |
581 | ||
582 | sub before_build { | |
583 | my ($self, $dir) = @_; | |
584 | } | |
585 | ||
586 | sub build { | |
587 | my $self = shift; | |
588 | eval { $self->do_build(@_) }; | |
589 | if ($@) { | |
590 | run_exit_handlers(); | |
591 | die $@; | |
592 | } | |
593 | } | |
594 | ||
595 | sub after_build { | |
596 | my ($self, $dir) = @_; | |
597 | } | |
598 | ||
599 | sub do_build { | |
600 | croak 'Dpkg::Source::Package does not know how to build a ' . | |
601 | 'source package; use one of the subclasses'; | |
602 | } | |
603 | ||
604 | sub can_build { | |
605 | my ($self, $dir) = @_; | |
606 | return (0, 'can_build() has not been overridden'); | |
607 | } | |
608 | ||
609 | sub add_file { | |
610 | my ($self, $filename) = @_; | |
611 | my ($fn, $dir) = fileparse($filename); | |
612 | if ($self->{checksums}->has_file($fn)) { | |
613 | croak "tried to add file '$fn' twice"; | |
614 | } | |
615 | $self->{checksums}->add_from_file($filename, key => $fn); | |
616 | $self->{checksums}->export_to_control($self->{fields}, | |
617 | use_files_for_md5 => 1); | |
618 | } | |
619 | ||
620 | sub commit { | |
621 | my $self = shift; | |
622 | eval { $self->do_commit(@_) }; | |
623 | if ($@) { | |
624 | run_exit_handlers(); | |
625 | die $@; | |
626 | } | |
627 | } | |
628 | ||
629 | sub do_commit { | |
630 | my ($self, $dir) = @_; | |
631 | info(g_("'%s' is not supported by the source format '%s'"), | |
632 | 'dpkg-source --commit', $self->{fields}{'Format'}); | |
633 | } | |
634 | ||
635 | sub write_dsc { | |
636 | my ($self, %opts) = @_; | |
637 | my $fields = $self->{fields}; | |
638 | ||
639 | foreach my $f (keys %{$opts{override}}) { | |
640 | $fields->{$f} = $opts{override}{$f}; | |
641 | } | |
642 | ||
643 | unless ($opts{nocheck}) { | |
644 | foreach my $f (qw(Source Version Architecture)) { | |
645 | unless (defined($fields->{$f})) { | |
646 | error(g_('missing information for critical output field %s'), $f); | |
647 | } | |
648 | } | |
649 | foreach my $f (qw(Maintainer Standards-Version)) { | |
650 | unless (defined($fields->{$f})) { | |
651 | warning(g_('missing information for output field %s'), $f); | |
652 | } | |
653 | } | |
654 | } | |
655 | ||
656 | foreach my $f (keys %{$opts{remove}}) { | |
657 | delete $fields->{$f}; | |
658 | } | |
659 | ||
660 | my $filename = $opts{filename}; | |
661 | $filename //= $self->get_basename(1) . '.dsc'; | |
662 | open(my $dsc_fh, '>', $filename) | |
663 | or syserr(g_('cannot write %s'), $filename); | |
664 | $fields->apply_substvars($opts{substvars}); | |
665 | $fields->output($dsc_fh); | |
666 | close($dsc_fh); | |
667 | } | |
668 | ||
669 | =back | |
670 | ||
671 | =head1 CHANGES | |
672 | ||
673 | =head2 Version 1.02 (dpkg 1.18.7) | |
674 | ||
675 | New option: require_strong_checksums in check_checksums(). | |
676 | ||
677 | =head2 Version 1.01 (dpkg 1.17.2) | |
678 | ||
679 | New functions: get_default_diff_ignore_regex(), set_default_diff_ignore_regex(), | |
680 | get_default_tar_ignore_pattern() | |
681 | ||
682 | Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern | |
683 | ||
684 | =head2 Version 1.00 (dpkg 1.16.1) | |
685 | ||
686 | Mark the module as public. | |
687 | ||
688 | =cut | |
689 | ||
690 | 1; |