File Coverage

blib/lib/CPANPLUS/Dist/Debora/Package/Debian.pm
Criterion Covered Total %
statement 216 280 77.1
branch 30 78 38.4
condition 3 8 37.5
subroutine 64 69 92.7
pod 15 15 100.0
total 328 450 72.8


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Debora::Package::Debian;
2              
3             # SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
4              
5 3     3   86571 use 5.016;
  3         13  
6 3     3   13 use warnings;
  3         6  
  3         81  
7 3     3   21 use utf8;
  3         5  
  3         20  
8              
9             our $VERSION = '0.010';
10              
11 3     3   126 use parent qw(CPANPLUS::Dist::Debora::Package);
  3         6  
  3         16  
12              
13 3     3   160 use Carp qw(croak);
  3         6  
  3         127  
14 3     3   16 use Config;
  3         6  
  3         122  
15 3     3   15 use English qw(-no_match_vars);
  3         6  
  3         20  
16 3     3   955 use File::Path qw(remove_tree);
  3         6  
  3         145  
17 3     3   16 use File::Spec::Functions qw(catdir catfile);
  3         7  
  3         146  
18 3     3   17 use Text::Template 1.22 qw();
  3         76  
  3         64  
19 3     3   15 use Text::Wrap qw();
  3         30  
  3         61  
20              
21             use CPANPLUS::Dist::Debora::Util
22 3     3   11 qw(parse_version can_run run spew_utf8 is_testing);
  3         6  
  3         204  
23 3     3   34 use CPANPLUS::Error qw(error);
  3         5  
  3         10024  
24              
25             # Map common machine architectures to Debian architectures.
26             #
27             # Only used if "dpkg --print-architecture" is not available.
28             my %ARCH_FOR = (
29             'aarch64' => 'arm64',
30             'armv6l' => 'armhf',
31             'armv7l' => 'armhf',
32             'i386' => 'i386',
33             'i486' => 'i386',
34             'i586' => 'i386',
35             'i686' => 'i386',
36             'ppc64le' => 'ppc64el',
37             's390x' => 's390x',
38             'x86_64' => 'amd64',
39             );
40              
41             # Map some distribution names to special package names.
42             #
43             # Taken from "/var/lib/dpkg/available" on Ubuntu 20.04. Some modules cannot
44             # be built without patches.
45             my %PACKAGE_NAME_FOR = (
46             'ack' => 'ack',
47             'AcePerl' => 'libace-perl',
48             'AllKnowingDNS' => 'all-knowing-dns',
49             'Apache-AuthCookie' => 'libapache2-authcookie-perl',
50             'Apache-Reload' => 'libapache2-reload-perl',
51             'App-Asciio' => 'asciio',
52             'App-ccdiff' => 'ccdiff',
53             'App-Cleo' => 'cleo',
54             'App-Cme' => 'cme',
55             'App-cpanminus' => 'cpanminus',
56             'App-Inotify-Hookable' => 'inotify-hookable',
57             'App-Licensecheck' => 'licensecheck',
58             'App-perlbrew' => 'perlbrew',
59             'App-perlrdf' => 'perlrdf',
60             'App-pmuninstall' => 'pmuninstall',
61             'App-Prolix' => 'prolix',
62             'App-PRT' => 'prt',
63             'App-Stacktrace' => 'perl-stacktrace',
64             'App-Whiff' => 'whiff',
65             'asterisk-perl' => 'libasterisk-agi-perl',
66             'BIND-Conf_Parser' => 'libbind-confparser-perl',
67             'BioPerl' => 'libbio-perl-perl',
68             'BioPerl-Run' => 'libbio-perl-run-perl',
69             'Carton' => 'carton',
70             'Catalyst-Runtime' => 'libcatalyst-perl',
71             'CGI' => 'libcgi-pm-perl',
72             'Courier-Filter' => 'courier-filter-perl',
73             'cpan-listchanges' => 'cpan-listchanges',
74             'cpan-outdated' => 'cpanoutdated',
75             'Crypt-HCE_SHA' => 'libcrypt-hcesha-perl',
76             'CursesWidgets' => 'libcurses-widgets-perl',
77             'DateConvert' => 'libdate-convert-perl',
78             'DBD-SQLite' => 'libdbd-sqlite3-perl',
79             'EasyTCP' => 'libnet-easytcp-perl',
80             'Feersum' => 'feersum',
81             'File-Rename' => 'rename',
82             'GDGraph' => 'libgd-graph-perl',
83             'GDTextUtil' => 'libgd-text-perl',
84             'Gearman' => 'libgearman-client-perl',
85             'Gearman-Server' => 'gearman-server',
86             'gettext' => 'liblocale-gettext-perl',
87             'IO-Tty' => 'libio-pty-perl',
88             'libintl-perl' => 'libintl-perl',
89             'libwww-perl' => 'libwww-perl',
90             'libxml-perl' => 'libxml-perl',
91             'Mail-MtPolicyd' => 'mtpolicyd',
92             'MIDI-Perl' => 'libmidi-perl',
93             'Net-SMTP_auth' => 'libnet-smtpauth-perl',
94             'NetxAP' => 'libnet-imap-perl',
95             'NNTPClient' => 'libnews-nntpclient-perl',
96             'perl-ldap' => 'libnet-ldap-perl',
97             'Perl-Tidy' => 'perltidy',
98             'perlindex' => 'perlindex',
99             'Pinto' => 'pinto',
100             'pmtools' => 'pmtools',
101             'pod2pdf' => 'pod2pdf',
102             'podlators' => 'podlators-perl',
103             'pRPC-modules' => 'libprpc-perl',
104             'Razor2-Client-Agent' => 'razor',
105             'rpm-build-perl' => 'libb-perlreq-perl',
106             'Sepia' => 'sepia',
107             'SMTP-Server' => 'libnet-smtp-server-perl',
108             'SOCKS' => 'libnet-socks-perl',
109             'Starlet' => 'starlet',
110             'Starman' => 'starman',
111             'Template-Toolkit' => 'libtemplate-perl',
112             'Template-DBI' => 'libtemplate-plugin-dbi-perl',
113             'Template-GD' => 'libtemplate-plugin-gd-perl',
114             'Template-XML' => 'libtemplate-plugin-xml-perl',
115             'TermReadKey' => 'libterm-readkey-perl',
116             'Tk' => 'perl-tk',
117             'Tree-DAG_Node' => 'libtree-dagnode-perl',
118             'Twiggy' => 'twiggy',
119             'Verilog-Perl' => 'libverilog-perl',
120             'W3C-LinkChecker' => 'w3c-linkchecker',
121             'X12' => 'libx12-parser-perl',
122             );
123              
124             # Add virtual packages to some Perl distributions.
125             my %PROVIDES_FOR = (
126             'App-CPANTS-Lint' => [qw(cpants-lint)],
127             'App-Nopaste' => [qw(nopaste)],
128             'BioPerl-Run' => [qw(bioperl-run)],
129             'circle-be' => [qw(circle-backend)],
130             'circle-fe-gtk' => [qw(circle-gtk)],
131             'Data-Pager' => [qw(libdatapager-perl)],
132             'GD' => [qw(libgd-gd2-perl libgd-gd2-noxpm-perl)],
133             'Hostfile-Manager' => [qw(hostfiles)],
134             'HTML-Lint' => [qw(weblint-perl)],
135             'IO-Tty' => [qw(libio-tty-perl)],
136             'libintl-perl' => [qw(libintl-xs-perl)],
137             'Mail-SPF' => [qw(spf-tools-perl)],
138             'Mail-SRS' => [qw(srs)],
139             'Markdent' => [qw(markdent)],
140             'Net-IPv4Addr' => [qw(libnetwork-ipv4addr-perl)],
141             'RTSP-Server' => [qw(rtsp-server-perl)],
142             'String-HexConvert' => [qw(libtext-string-hexconvert-perl)],
143             'Text-BibTeX' => [qw(libbtparse2 libbtparse-dev)],
144             'XML-SimpleObject' =>
145             [qw(libxml-simpleobject-enhanced-perl libxml-simpleobject-libxml-perl)],
146             'XML-Twig' => [qw(xml-twig-tools)],
147             );
148              
149             # Files, that are also provided by Debian's "perl" package, cannot be
150             # overwritten and have to be put into "/usr/local".
151             my %INSTALLDIRS_FOR = map { $_ => 'site' } qw(
152             Archive-Tar
153             CPAN
154             Digest-SHA
155             Encode
156             ExtUtils-MakeMaker
157             ExtUtils-ParseXS
158             IO-Compress
159             JSON-PP
160             Module-CoreList
161             Pod-Checker
162             Pod-Parser
163             Pod-Perldoc
164             Pod-Usage
165             podlators
166             Test-Harness
167             );
168              
169             # Version quirks.
170             my %VERSION_FOR
171             = ('JSON-PP' => sub { sprintf '%.5f', parse_version($_[0]) });
172              
173             sub format_priority {
174 2     2 1 6 my $class = shift;
175              
176 2         7 my @commands = qw(dpkg dpkg-buildpackage dh fakeroot find tar);
177              
178 2         4 my $priority = 0;
179 2 50       6 if (@commands == grep { can_run($_) } @commands) {
  12         164676  
180 0         0 $priority = 1;
181 0 0       0 if (-f '/etc/debian_version') {
182 0         0 $priority = 2;
183             }
184             }
185              
186 2         578 return $priority;
187             }
188              
189             sub create {
190 0     0 1 0 my ($self, %options) = @_;
191              
192             # Populate the debian directory.
193 0         0 my $ok = $self->_write_debian('changelog', $self->changelog);
194 0 0       0 if ($ok) {
195 0         0 $ok = $self->_write_debian('control', $self->control);
196             }
197 0 0       0 if ($ok) {
198 0         0 $ok = $self->_write_debian('copyright', $self->copyright);
199             }
200 0 0       0 if ($ok) {
201 0         0 $ok = $self->_write_debian('docs', $self->docs);
202             }
203 0 0       0 if ($ok) {
204 0         0 $ok = $self->_write_debian('rules', $self->rules, oct '0755');
205             }
206              
207             # Create the package.
208 0 0       0 if ($ok) {
209 0         0 my @buildpackage_cmd = qw(dpkg-buildpackage -b -nc -rfakeroot);
210 0         0 push @buildpackage_cmd, '-uc'; # No signing for now.
211              
212             $ok = run(
213             command => \@buildpackage_cmd,
214             dir => $self->builddir,
215             verbose => $options{verbose},
216 0         0 );
217             }
218              
219 0         0 return $ok;
220             }
221              
222             sub install {
223 0     0 1 0 my ($self, %options) = @_;
224              
225 0         0 my $sudo_cmd = $self->sudo_cmd;
226 0         0 my @install_cmd = ($sudo_cmd, qw(dpkg --install));
227              
228 0 0       0 if (is_testing) {
229 0         0 @install_cmd = qw(dpkg --contents);
230             }
231              
232 0         0 push @install_cmd, $self->outputname;
233              
234 0         0 my $ok = run(command => \@install_cmd, verbose => $options{verbose});
235              
236 0         0 return $ok;
237             }
238              
239             sub outputname {
240 1     1 1 3 my $self = shift;
241              
242             my $outputname = $self->_read(
243             'outputname',
244             sub {
245 1     1   14 catfile($self->outputdir,
246             $self->name . q{_}
247             . $self->version . q{-}
248             . $self->revision . q{_}
249             . $self->arch
250             . q{.deb});
251             }
252 1         17 );
253              
254 1         10 return $outputname;
255             }
256              
257             sub installdirs {
258 2     2 1 263 my $self = shift;
259              
260 2   33     6 my $installdirs = $INSTALLDIRS_FOR{$self->dist_name}
261             // $self->SUPER::installdirs;
262              
263 2         4 return $installdirs;
264             }
265              
266             sub arch {
267 1     1 1 3 my $self = shift;
268              
269 1     1   30 my $arch = $self->_read('arch', sub { $self->_get_arch });
  1         9  
270              
271 1         10 return $arch;
272             }
273              
274             sub version_with_epoch {
275 1     1 1 210 my $self = shift;
276              
277             my $version = $self->_read('version_with_epoch',
278 1     1   13 sub { $self->_get_version_with_epoch });
  1         5  
279              
280 1         10 return $version;
281             }
282              
283             sub revision {
284 2     2 1 167 my $self = shift;
285              
286             my $revision = $self->_read('revision',
287 2     1   20 sub { $self->build_number . $self->_get_mangled_vendor });
  1         6  
288              
289 2         18 return $revision;
290             }
291              
292             sub debiandir {
293 1     1 1 3 my $self = shift;
294              
295 1     0   10 my $debiandir = $self->_read('debiandir', sub { $self->_get_debiandir });
  0         0  
296              
297 1         7 return $debiandir;
298             }
299              
300             sub provides {
301 1     1 1 10 my $self = shift;
302              
303 1         5 my $dist_name = $self->dist_name;
304              
305 1         58 my @provides;
306 1 50       4 if (exists $PROVIDES_FOR{$dist_name}) {
307 0         0 push @provides, @{$PROVIDES_FOR{$dist_name}};
  0         0  
308             }
309              
310 1         3 return \@provides;
311             }
312              
313             sub _date {
314 4     4   9 my ($self, $timestamp) = @_;
315              
316 4         43 my ($week_day, $month, $day, $time, $year) = split q{ },
317             scalar gmtime $timestamp;
318              
319 4         21 my $date = sprintf '%s, %02d %s %s %s +0000', $week_day, $day, $month,
320             $year, $time;
321              
322 4         27 return $date;
323             }
324              
325             sub _fill_in {
326 4     4   10 my ($self, $template, %vars) = @_;
327              
328 4         19 my $text = $template->fill_in(
329             STRICT => 1,
330             HASH => {
331             package => \$self,
332             date => $self->_date($self->last_modification),
333             %vars
334             },
335             );
336              
337 4         1042 return $text;
338             }
339              
340             sub changelog {
341 1     1 1 4 my ($self, %vars) = @_;
342              
343 1         25 my $template = Text::Template->new(
344             DELIMITERS => ['[%', '%]'],
345             TYPE => 'STRING',
346             SOURCE => <<'END_TEMPLATE');
347             [% $package->name %] ([% $package->version_with_epoch %]-[% $package->revision %]) unstable; urgency=low
348              
349             * Package [% $package->dist_name %] [% $package->version %]
350              
351             -- [% $package->packager %] [% $date %]
352              
353             END_TEMPLATE
354              
355 1         221 my $text = $self->_fill_in($template, %vars);
356              
357 1         15 return $text;
358             }
359              
360             sub control {
361 1     1 1 540 my ($self, %vars) = @_;
362              
363 1         16 my $template = Text::Template->new(
364             DELIMITERS => ['[%', '%]'],
365             TYPE => 'STRING',
366             SOURCE => <<'END_TEMPLATE');
367             Source: [% $package->name %]
368             Maintainer: [% $package->packager %]
369             Section: perl
370             Priority: optional
371             Build-Depends: debhelper-compat (= 12)
372             Standards-Version: 4.6.0
373             Homepage: [% $package->url %]
374              
375             Package: [% $package->name %]
376             [%
377             $OUT .= 'Architecture: ';
378             $OUT .= $package->is_noarch ? 'all' : 'any';
379             my @provides = @{$package->provides};
380             if (@provides) {
381             $OUT .= "\n";
382             $OUT .= 'Provides: ';
383             $OUT .= shift @provides;
384             for my $name (@provides) {
385             $OUT .= ", $name";
386             }
387             }
388             q{};
389             %]
390             [%
391             $OUT .= 'Depends: ${misc:Depends}, ${perl:Depends}';
392             if (!$package->is_noarch) {
393             $OUT .= ', ${shlibs:Depends}';
394             }
395             my %unique_dependencies =
396             map { $_->{package_name} => $_ } @{$package->dependencies};
397             my @dependencies =
398             sort { $a->{package_name} cmp $b->{package_name} }
399             grep { !$_->{is_core} } values %unique_dependencies;
400             for my $dependency (@dependencies) {
401             my $name = $dependency->{package_name};
402             my $version = $dependency->{version};
403             $OUT .= ", $name";
404             if ($version) {
405             $OUT .= " (>= $version)";
406             }
407             if ($name eq 'libdata-uuid-perl') {
408             $OUT .= ' | libossp-uuid-perl';
409             }
410             }
411             q{};
412             %]
413             Description: [% $package->summary %]
414             [%
415             local $Text::Wrap::unexpand = 0;
416             my $text = Text::Wrap::wrap(q{ }, q{ }, $package->description);
417             $text =~ s{^ [ ] [.]}{ \N{U+200B}.}xmsg; # Put a non-visible space before dots.
418             $text =~ s{^ [ ] (\h*) $}{ .$1}xmsg; # Put a dot into empty lines.
419             $text;
420             %]
421             END_TEMPLATE
422              
423 1         112 my $text = $self->_fill_in($template, %vars);
424              
425 1         12 return $text;
426             }
427              
428             sub copyright {
429 1     1 1 2942 my ($self, %vars) = @_;
430              
431 1         8 my $template = Text::Template->new(
432             DELIMITERS => ['[%', '%]'],
433             TYPE => 'STRING',
434             SOURCE => <<'END_TEMPLATE');
435             Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
436              
437             Files: *
438             [%
439             my @copyrights = @{$package->copyrights};
440             my @licenses = @{$package->licenses};
441              
442             my $is_first = 1;
443             for my $copyright (@copyrights) {
444             my $year = $copyright->{year};
445             my $holder = $copyright->{holder};
446              
447             $OUT .= $is_first ? 'Copyright: ' : q{ } x 11;
448             $OUT .= "$year $holder\n";
449              
450             $is_first = 0;
451             }
452              
453             $OUT .= 'License: ' . $package->license . "\n";
454              
455             for my $license (@licenses) {
456             my $text = $package->_get_license_text($license);
457              
458             if (@licenses > 1) {
459             my $name = $license->spdx_expression;
460             $OUT .= "\nLicense: $name\n";
461             }
462              
463             $OUT .= $text;
464              
465             if (@licenses > 1) {
466             $OUT .= "\n";
467             }
468             }
469             q{};
470             %]
471             END_TEMPLATE
472              
473 1         129 my $text = $self->_fill_in($template, %vars);
474              
475 1         6 return $text;
476             }
477              
478             sub docs {
479 1     1 1 1507 my ($self, %vars) = @_;
480              
481             # Ignore the first changelog file, which is installed with
482             # dh_installchangelogs.
483 1         2 my (undef, @files) = @{$self->files_by_type('changelog')};
  1         12  
484 1         2 push @files, @{$self->files_by_type('doc')};
  1         4  
485              
486 1         4 my $text = join q{}, map { $_ . "\n" } @files;
  3         8  
487              
488 1         3 return $text;
489             }
490              
491             sub rules {
492 1     1 1 498 my ($self, %vars) = @_;
493              
494 1         8 my $template = Text::Template->new(
495             DELIMITERS => ['[%', '%]'],
496             TYPE => 'STRING',
497             SOURCE => <<'END_TEMPLATE');
498             #!/usr/bin/make -f
499              
500             %:
501             dh $@
502              
503             override_dh_auto_configure:
504              
505             override_dh_auto_build:
506              
507             override_dh_auto_test:
508              
509             override_dh_auto_install:
510             mkdir -p '[% $package->_buildrootdir %]'
511             tar -C '[% $package->stagingdir %]' -cf - . | tar -C '[% $package->_buildrootdir %]' -xf -
512             [%
513             my ($first_changelog) = @{$package->files_by_type('changelog')};
514             if ($first_changelog) {
515             $OUT .= "\noverride_dh_installchangelogs:\n";
516             $OUT .= "\tdh_installchangelogs $first_changelog";
517             }
518             q{};
519             %]
520             [%
521             my $installdirs = $package->installdirs;
522             if ($installdirs eq 'site') {
523             my $buildrootdir = $package->_buildrootdir;
524             my $debiandocdir = $package->_debiandocdir;
525             my $sitedocdir = $package->_sitedocdir;
526              
527             $OUT .= "\noverride_dh_usrlocal:\n";
528              
529             $OUT .= "\nexecute_before_dh_installdeb:\n";
530             $OUT .= "\tmkdir -p '$sitedocdir' && \\\n";
531             $OUT .= "\ttar -C '$debiandocdir' -cf - . | tar -C '$sitedocdir' -xf - && \\\n";
532             $OUT .= "\trm -rf '$debiandocdir'\n";
533             $OUT .= "\tfind '$buildrootdir' -type d -empty -delete";
534             }
535             q{};
536             %]
537             END_TEMPLATE
538              
539 1         116 my $text = $self->_fill_in($template, %vars);
540              
541 1         8 return $text;
542             }
543              
544             sub DESTROY {
545 1     1   487 my $self = shift;
546              
547 1         3 my $debiandir = $self->{debiandir};
548 1 50       4 if (defined $debiandir) {
549             ##no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
550 1         3 eval { remove_tree($debiandir) };
  1         358  
551             }
552              
553 1         12 $self->SUPER::DESTROY;
554              
555 1         3 return;
556             }
557              
558             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
559              
560             sub _normalize_name {
561 8     8   5038 my ($self, $dist_name) = @_;
562              
563 8         12 my $name;
564 8 100       28 if (exists $PACKAGE_NAME_FOR{$dist_name}) {
565 2         5 $name = $PACKAGE_NAME_FOR{$dist_name};
566             }
567             else {
568 6         19 $name = 'lib' . lc($dist_name) . '-perl';
569 6         14 $name =~ tr{_}{-};
570             }
571              
572 8         27 return $name;
573             }
574              
575             sub _normalize_version {
576 5     5   71 my ($self, $dist_version) = @_;
577              
578 5         12 my $dist_name = $self->dist_name;
579              
580             my $version
581             = exists $VERSION_FOR{$dist_name}
582 5 50       268 ? $VERSION_FOR{$dist_name}->($dist_version)
583             : $self->SUPER::_normalize_version($dist_version);
584              
585 5         34 return $version;
586             }
587              
588             sub _buildrootdir {
589 5     5   1146 my $self = shift;
590              
591             my $buildrootdir = $self->_read('_buildrootdir',
592 5     1   27 sub { catdir($self->debiandir, $self->name) });
  1         6  
593              
594 5         84 return $buildrootdir;
595             }
596              
597             sub _debiandocdir {
598 1     1   8 my $self = shift;
599              
600             my $docdir = $self->_read('_debiandocdir',
601 1     1   13 sub { catdir($self->_buildrootdir, 'usr', 'share', 'doc') });
  1         2  
602              
603 1         3 return $docdir;
604             }
605              
606             sub _sitedocdir {
607 1     1   6 my $self = shift;
608              
609             my $docdir = $self->_read(
610             'sitedocdir',
611             sub {
612 1     1   3 catdir($self->_buildrootdir, $Config{siteprefix}, 'share', 'doc');
613             }
614 1         11 );
615              
616 1         4 return $docdir;
617             }
618              
619             sub _get_debiandir {
620 0     0   0 my $self = shift;
621              
622 0         0 my $debiandir = catdir($self->builddir, 'debian');
623              
624             # Remove a possibly existing debian directory.
625 0 0       0 if (-e $debiandir) {
626 0         0 remove_tree($debiandir);
627             }
628              
629             # Create the debian directory.
630 0 0       0 if (!mkdir $debiandir) {
631 0         0 croak "Could not create '$debiandir': $OS_ERROR";
632             }
633              
634 0         0 return $debiandir;
635             }
636              
637             sub _get_arch {
638 1     1   3 my $self = shift;
639              
640 1         2 my $arch;
641              
642 1 50       6 if ($self->is_noarch) {
643 1         5 $arch = 'all';
644             }
645             else {
646 0         0 my $dpkg_cmd = can_run('dpkg');
647 0 0       0 if ($dpkg_cmd) {
648 0         0 my $output = q{};
649 0         0 my @arch_cmd = ($dpkg_cmd, '--print-architecture');
650 0 0       0 if (run(command => \@arch_cmd, buffer => \$output)) {
651 0         0 chomp $output;
652 0         0 $arch = $output;
653             }
654             }
655             }
656              
657 1 50       5 if (!$arch) {
658 0         0 my $machine = (POSIX::uname)[4];
659 0 0       0 if (exists $ARCH_FOR{$machine}) {
660 0         0 $arch = $ARCH_FOR{$machine};
661             }
662             else {
663 0         0 croak "Unknown hardware architecture: '$machine'";
664             }
665             }
666              
667 1         9 return $arch;
668             }
669              
670             sub _read_epochs {
671 2     2   544 my $self = shift;
672              
673 2         13 my %epoch_for = ('libscalar-list-utils-perl' => 1);
674              
675 2         4 my $name;
676 2 50       2707 if (open my $fh, '<', '/var/lib/dpkg/available') {
677 2         684 while (my $line = <$fh>) {
678 4956         5845 chomp $line;
679              
680 4956 100       12660 if ($line =~ m{^ Package: \h+ (.+) $}xms) {
    100          
    100          
681 196         555 $name = $1;
682             }
683             elsif ($line =~ m{^ Version: \h+ (\d+) :}xms) {
684 34         53 my $epoch = $1;
685              
686 34 50       58 if (defined $name) {
687 34         74 $epoch_for{$name} = $epoch;
688 34         80 undef $name;
689             }
690             }
691             elsif ($line eq q{}) {
692 196         363 undef $name;
693             }
694             }
695 2 50       30 close $fh or undef;
696             }
697              
698 2         23 return \%epoch_for;
699             }
700              
701             sub _get_epoch_from_env {
702 1     1   3 my $self = shift;
703              
704 1         2 my $epoch = 0;
705 1 50 33     43 if (defined $ENV{EPOCH} && $ENV{EPOCH} =~ m{\A \d+ \z}xms) {
706 0         0 $epoch = $ENV{EPOCH};
707             }
708              
709 1         4 return $epoch;
710             }
711              
712             sub _get_epoch_from_system {
713 1     1   2 my $self = shift;
714              
715 1         2 my %epoch_for = %{$self->_read_epochs};
  1         5  
716 1   50     9 my $epoch = $epoch_for{$self->name} // 0;
717              
718 1         6 return $epoch;
719             }
720              
721             sub _get_epoch {
722 1     1   3 my $self = shift;
723              
724 1         8 my $epoch_env = $self->_get_epoch_from_env;
725 1         4 my $epoch_sys = $self->_get_epoch_from_system;
726 1 50       3 my $epoch = $epoch_env > $epoch_sys ? $epoch_env : $epoch_sys;
727              
728 1         2 return $epoch;
729             }
730              
731             sub _get_version_with_epoch {
732 1     1   2 my $self = shift;
733              
734 1         6 my $version = $self->SUPER::version;
735              
736 1         5 my $epoch = $self->_get_epoch;
737 1 50       4 if ($epoch) {
738 0         0 $version = $epoch . q{:} . $version;
739             }
740              
741 1         3 return $version;
742             }
743              
744             sub _get_mangled_vendor {
745 1     1   3 my $self = shift;
746              
747 1         7 my $vendor = lc $self->vendor;
748 1         3 $vendor =~ tr{a-z0-9}{}cd; # Remove anything but alphanumeric characters.
749 1         8 $vendor =~ s{\A \d+}{}xms; # Remove leading numbers.
750              
751 1         6 return $vendor;
752             }
753              
754             sub _write_debian {
755 0     0   0 my ($self, $name, $text, $mode) = @_;
756              
757 0         0 my $debiandir = $self->debiandir;
758              
759 0         0 my $ok = 0;
760              
761 0 0       0 if (!defined $text) {
762 0         0 error("Could not render the $name file");
763             }
764             else {
765 0         0 my $filename = catfile($debiandir, $name);
766 0         0 $ok = spew_utf8($filename, $text);
767 0 0       0 if (!$ok) {
768 0         0 error("Could not create '$filename': $OS_ERROR");
769             }
770             else {
771 0 0       0 if (defined $mode) {
772 0         0 $ok = chmod $mode, $filename;
773 0 0       0 if (!$ok) {
774 0         0 error("Could not chmod '$filename': $OS_ERROR");
775             }
776             }
777             }
778             }
779              
780 0         0 return $ok;
781             }
782              
783             sub _get_license_apache_2_0 {
784 1     1   3 my $self = shift;
785              
786 1         7 return <<'END_LICENSE';
787             Licensed under the Apache License, Version 2.0 (the "License");
788             you may not use this file except in compliance with the License.
789             You may obtain a copy of the License at
790              
791             http://www.apache.org/licenses/LICENSE-2.0
792              
793             Unless required by applicable law or agreed to in writing, software
794             distributed under the License is distributed on an "AS IS" BASIS,
795             WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
796             See the License for the specific language governing permissions and
797             limitations under the License.
798              
799             On Debian systems, the complete text of version 2.0 of the Apache
800             License can be found in `/usr/share/common-licenses/Apache-2.0'.
801             END_LICENSE
802             }
803              
804             sub _get_license_cc0_1_0 {
805 1     1   2 my $self = shift;
806              
807 1         4 return <<'END_LICENSE';
808             To the extent possible under law, the author(s) have dedicated all
809             copyright and related and neighboring rights to this software to the
810             public domain worldwide. This software is distributed without any
811             warranty.
812              
813             On Debian systems, the complete text of the CC0 1.0 Universal license
814             can be found in `/usr/share/common-licenses/CC0-1.0'.
815             END_LICENSE
816             }
817              
818             sub _get_license_fsf {
819 5     5   63 my ($self, $file, $version) = @_;
820              
821 5         13 my $name = q{};
822 5 100       23 if ($file =~ m{\A GPL-}xms) {
    50          
823 3         11 $name = 'GNU General Public License';
824             }
825             elsif ($file =~ m{\A LGPL-}xms) {
826 2         3 $name = 'GNU Lesser General Public License';
827             }
828             else {
829 0         0 croak "Unknown license: '$file'";
830             }
831              
832 5         20 my $text = <<"END_LICENSE";
833             This is free software; you can redistribute it and/or modify it under
834             the terms of the $name as published by the Free Software Foundation;
835             either version $version of the License, or (at your option) any later
836             version.
837              
838             On Debian systems, the complete text of version $version of the $name
839             can be found in `/usr/share/common-licenses/$file'.
840             END_LICENSE
841              
842 5         13 return Text::Wrap::wrap(q{ }, q{ }, $text);
843             }
844              
845             sub _get_license_mozilla {
846 2     2   5 my ($self, $file, $version) = @_;
847              
848 2         10 return <<"END_LICENSE";
849             This is free software; you can redistribute it and/or modify it under
850             the terms of the Mozilla Public License, version $version.
851              
852             On Debian systems, the complete text of version $version of the Mozilla
853             Public License can be found in `/usr/share/common-licenses/$file'.
854             END_LICENSE
855             }
856              
857             sub _get_license_perl_5 {
858 2     2   4 my $self = shift;
859              
860 2         8 return <<'END_LICENSE';
861             This is free software; you can redistribute it and/or modify it under
862             the same terms as Perl itself, i.e. the terms of either:
863              
864             a) the GNU General Public License as published by the Free Software
865             Foundation; either version 1, or (at your option) any later version,
866             or
867              
868             b) the "Artistic License".
869              
870             On Debian systems, the complete text of version 1 of the GNU General
871             Public License can be found in `/usr/share/common-licenses/GPL-1'.
872              
873             The complete text of the "Artistic License" can be found in
874             `/usr/share/common-licenses/Artistic'.
875             END_LICENSE
876             }
877              
878             sub _get_license_text {
879 11     11   1086 my ($self, $license) = @_;
880              
881 11         62 my $name = $license->spdx_expression;
882 11         90 my $meta2_name = $license->meta2_name;
883 11 100       86 if ($meta2_name eq 'open_source') {
    100          
884 1 50       5 if ($name eq 'MPL-2.0') {
885 1         2 $meta2_name = 'mozilla_2_0';
886             }
887             }
888             elsif ($meta2_name eq 'unrestricted') {
889 1 50       5 if ($name eq 'CC0-1.0') {
890 1         2 $meta2_name = 'cc0_1_0';
891             }
892             }
893              
894             my %license_text_for = (
895 1     1   9 apache_2_0 => sub { $self->_get_license_apache_2_0 },
896 1     1   8 cc0_1_0 => sub { $self->_get_license_cc0_1_0 },
897 1     1   7 gpl_1 => sub { $self->_get_license_fsf('GPL-1', '1') },
898 1     1   3 gpl_2 => sub { $self->_get_license_fsf('GPL-2', '2') },
899 1     1   6 gpl_3 => sub { $self->_get_license_fsf('GPL-3', '3') },
900 1     1   6 lgpl_2_1 => sub { $self->_get_license_fsf('LGPL-2.1', '2.1') },
901 1     1   3 lgpl_3_0 => sub { $self->_get_license_fsf('LGPL-3', '3.0') },
902 1     1   6 mozilla_1_1 => sub { $self->_get_license_mozilla('MPL-1.1', '1.1') },
903 1     1   3 mozilla_2_0 => sub { $self->_get_license_mozilla('MPL-2.0', '2.0') },
904 2     2   13 perl_5 => sub { $self->_get_license_perl_5 },
905 11         184 );
906              
907             my $text
908             = exists $license_text_for{$meta2_name}
909 11 50       36 ? $license_text_for{$meta2_name}->()
910             : $license->license;
911 11         4153 $text =~ s{\s+ \z}{}xms; # Remove trailing spaces.
912 11         92 $text =~ s{^}{ }xmsg; # Indent the license text.
913 11         128 $text =~ s{^ [ ] (\h*) $}{ .$1}xmsg; # Put a dot into empty lines.
914              
915 11         158 return $text;
916             }
917              
918             1;
919             __END__