File Coverage

blib/lib/CPANPLUS/Dist/Slackware/PackageDescription.pm
Criterion Covered Total %
statement 30 261 11.4
branch 0 80 0.0
condition 0 35 0.0
subroutine 10 42 23.8
pod 25 25 100.0
total 65 443 14.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Slackware::PackageDescription;
2              
3 1     1   7 use strict;
  1         3  
  1         31  
4 1     1   5 use warnings;
  1         2  
  1         42  
5              
6             our $VERSION = '1.030';
7              
8 1     1   6 use English qw( -no_match_vars );
  1         3  
  1         5  
9              
10 1     1   804 use CPANPLUS::Dist::Slackware::Util qw(catdir catfile tmpdir);
  1         4  
  1         91  
11              
12 1     1   10 use Config;
  1         2  
  1         44  
13 1     1   806 use File::Temp qw();
  1         10434  
  1         52  
14 1     1   3086 use Module::CoreList qw();
  1         110008  
  1         676  
15 1     1   18 use POSIX qw();
  1         2  
  1         36  
16 1     1   760 use Text::Wrap qw($columns);
  1         2646  
  1         143  
17 1     1   8 use version 0.77 qw();
  1         21  
  1         3155  
18              
19             sub new {
20 0     0 1   my ( $class, %attrs ) = @_;
21 0           return bless \%attrs, $class;
22             }
23              
24             sub module {
25 0     0 1   my $self = shift;
26 0           return $self->{module};
27             }
28              
29             sub _normalize_name {
30 0     0     my $name = shift;
31              
32             # Remove "-perl" from the end of the name.
33 0 0         if ( $name ne 'uni-perl' ) {
34 0           $name =~ s/-perl$//;
35             }
36              
37             # Prepend "perl-" unless the name starts with "perl-".
38 0 0         if ( $name !~ /^perl-/ ) {
39 0           $name = 'perl-' . $name;
40             }
41              
42             # Prepend "c" if the package is built for cperl.
43 0 0         if ( defined $Config{'usecperl'} ) {
44 0           $name = 'c' . $name;
45             }
46              
47 0           return $name;
48             }
49              
50             sub _normalize_version {
51 0     0     my $version = shift;
52              
53 0 0         if ( !defined $version ) {
54 0           $version = 0;
55             }
56             else {
57 0           $version =~ s/^v//;
58             }
59 0           return $version;
60             }
61              
62             sub normalized_name {
63 0     0 1   my $self = shift;
64 0           my $name = $self->{normalized_name};
65 0 0         if ( !$name ) {
66 0           $name = _normalize_name( $self->module->package_name );
67 0           $self->{normalized_name} = $name;
68             }
69 0           return $name;
70             }
71              
72             sub normalized_version {
73 0     0 1   my $self = shift;
74 0           my $version = $self->{normalized_version};
75 0 0         if ( !$version ) {
76 0           $version = _normalize_version( $self->module->package_version );
77 0           $self->{normalized_version} = $version;
78             }
79 0           return $version;
80             }
81              
82             sub distname {
83 0     0 1   my $self = shift;
84 0           return $self->normalized_name . q{-} . $self->normalized_version;
85             }
86              
87             sub build {
88 0     0 1   my $self = shift;
89              
90 0   0       return $self->{build} || $ENV{BUILD} || 1;
91             }
92              
93             sub set_build {
94 0     0 1   my ( $self, $build ) = @_;
95              
96 0           return $self->{build} = $build;
97             }
98              
99             sub arch {
100 0     0 1   my $self = shift;
101 0   0       my $arch = $self->{arch} || $ENV{ARCH};
102 0 0         if ( !$arch ) {
103 0           $arch = (POSIX::uname)[4];
104 0 0         if ( $arch =~ /^i.86$/ ) {
    0          
105 0           $arch = 'i586';
106             }
107             elsif ( $arch =~ /^arm/ ) {
108 0           $arch = 'arm';
109             }
110             }
111 0           return $arch;
112             }
113              
114             sub tag {
115 0     0 1   my $self = shift;
116 0   0       return $self->{tag} || $ENV{TAG} || '_CPANPLUS';
117             }
118              
119             sub type {
120 0     0 1   my $self = shift;
121 0   0       return $self->{type} || $ENV{PKGTYPE} || 'tgz';
122             }
123              
124             sub filename {
125 0     0 1   my $self = shift;
126 0           my $filename
127             = $self->distname . q{-}
128             . $self->arch . q{-}
129             . $self->build
130             . $self->tag . q{.}
131             . $self->type;
132 0           return $filename;
133             }
134              
135             sub outputdir {
136 0     0 1   my $self = shift;
137 0   0       return $self->{outputdir} || $ENV{OUTPUT} || tmpdir();
138             }
139              
140             sub outputname {
141 0     0 1   my $self = shift;
142 0           my $outputname = $self->filename;
143 0           my $outputdir = $self->outputdir;
144 0 0         if ($outputdir) {
145 0           $outputname = catfile( $outputdir, $outputname );
146             }
147 0           return $outputname;
148             }
149              
150             sub installdirs {
151 0     0 1   my $self = shift;
152 0           return $self->{installdirs};
153             }
154              
155             sub prefix {
156 0     0 1   my $self = shift;
157              
158 0           my $installdirs = $self->installdirs;
159              
160 0           return $Config{"${installdirs}prefixexp"};
161             }
162              
163             sub bindir {
164 0     0 1   my $self = shift;
165              
166 0           my $installdirs = $self->installdirs;
167              
168 0           return $Config{"${installdirs}binexp"};
169             }
170              
171             sub mandirs {
172 0     0 1   my $self = shift;
173              
174 0           my $installdirs = $self->installdirs;
175              
176             my %mandir = map {
177 0           my $dir = $Config{"${installdirs}man${_}direxp"};
  0            
178 0 0         if ( !$dir ) {
179 0           $dir = catdir( $self->prefix, 'man', "man${_}" );
180             }
181 0           $dir =~ s,/usr/share/man/,/usr/man/,;
182 0           $_ => $dir
183             } ( 1, 3 );
184 0           return %mandir;
185             }
186              
187             sub docdir {
188 0     0 1   my $self = shift;
189              
190 0           my $installdirs = $self->installdirs;
191              
192 0           return catfile( $self->prefix, 'doc', $self->distname );
193             }
194              
195             sub docfiles {
196 0     0 1   my $self = shift;
197 0           my $module = $self->module;
198              
199 0           my $wrksrc = $module->status->extract;
200 0 0         return if !$wrksrc;
201              
202 0           my $dh;
203 0 0         opendir( $dh, $wrksrc ) or return;
204             my @docfiles = grep {
205 0 0         m{ ^(?:
  0            
206             AUTHORS
207             | BUGS
208             | Change(?:s|Log)(?:\.md)?
209             | COPYING(?:\.(?:LESSER|LIB))?
210             | CREDITS
211             | FAQ
212             | LICEN[CS]E
213             | NEWS
214             | README(?:\.(?:md|pod))?
215             | THANKS
216             | TODO
217             )$
218             }xi && -f catfile( $wrksrc, $_ )
219             } readdir $dh;
220 0           closedir $dh;
221 0           return @docfiles;
222             }
223              
224             sub _summary_from_pod {
225 0     0     my $self = shift;
226 0           my $module = $self->module;
227 0           my $srcname = $module->module;
228              
229 0 0         eval {
230 0           require Pod::Find;
231 0           require Pod::Simple::PullParser;
232             } or return;
233              
234 0           my $wrksrc = $module->status->extract;
235 0 0         return if !$wrksrc;
236              
237 0           my $summary = q{};
238             my @dirs = (
239 0           map { catdir( $wrksrc, $_ ) } qw(blib/lib blib/bin lib bin), $wrksrc
  0            
240             );
241 0           my $podfile = Pod::Find::pod_where( { -dirs => \@dirs }, $srcname );
242 0 0         if ($podfile) {
243 0           my $parser = Pod::Simple::PullParser->new;
244 0           $parser->set_source($podfile);
245 0           my $title = $parser->get_title;
246 0 0 0       if ( $title && $title =~ /^(?:\S+\s+)+?-+\s+(.+)/xs ) {
247 0           $summary = $1;
248             }
249             else {
250              
251             # XXX Try harder to find a summary.
252             }
253             }
254 0           return $summary;
255             }
256              
257             sub _summary_from_meta {
258 0     0     my $self = shift;
259 0           my $module = $self->module;
260              
261 0 0         eval { require Parse::CPAN::Meta } or return;
  0            
262              
263 0           my $wrksrc = $module->status->extract;
264 0 0         return if !$wrksrc;
265              
266 0           my $summary = q{};
267 0           for (qw(META.yml META.json)) {
268 0           my $metafile = catfile( $wrksrc, $_ );
269 0 0         if ( -f $metafile ) {
270 0           my $distmeta;
271 0 0         eval { $distmeta = Parse::CPAN::Meta::LoadFile($metafile) }
  0            
272             or next;
273 0 0 0       if ( $distmeta
      0        
274             && $distmeta->{abstract}
275             && $distmeta->{abstract} !~ /unknown/i )
276             {
277 0           $summary = $distmeta->{abstract};
278 0           last;
279             }
280             }
281             }
282 0           return $summary;
283             }
284              
285             sub summary {
286 0     0 1   my $self = shift;
287 0           my $module = $self->module;
288              
289 0   0       my $summary
290             = $self->_summary_from_meta
291             || $module->description
292             || $self->_summary_from_pod
293             || q{};
294 0           $summary =~ s/[\r\n]+/ /g; # Replace vertical whitespace.
295 0           return $summary;
296             }
297              
298             sub _webpage {
299 0     0     my $self = shift;
300 0           my $module = $self->module;
301 0           my $name = $module->package_name;
302              
303 0           return "https://metacpan.org/release/$name";
304             }
305              
306             sub config_function {
307 0     0 1   my $self = shift;
308              
309 0           return <<'END_CONFIG';
310             config() {
311             NEW=$1
312             OLD=${NEW%.new}
313             # If there's no config file by that name, mv it over:
314             if [ ! -r "$OLD" ]; then
315             mv "$NEW" "$OLD"
316             elif [ -f "$NEW" -a -f "$OLD" ]; then
317             NEWCKSUM=$(cat "$NEW" | md5sum)
318             OLDCKSUM=$(cat "$OLD" | md5sum)
319             if [ "$NEWCKSUM" = "$OLDCKSUM" ]; then
320             # toss the redundant copy
321             rm "$NEW"
322             else
323             # preserve perms
324             cp -p "$OLD" "${NEW}.incoming"
325             cat "$NEW" > "${NEW}.incoming"
326             mv "${NEW}.incoming" "$NEW"
327             fi
328             elif [ -h "$NEW" -a -h "$OLD" ]; then
329             NEWLINK=$(readlink -n "$NEW")
330             OLDLINK=$(readlink -n "$OLD")
331             if [ "$NEWLINK" = "$OLDLINK" ]; then
332             # remove the redundant link
333             rm "$NEW"
334             fi
335             fi
336             # Otherwise, we leave the .new copy for the admin to consider...
337             }
338             END_CONFIG
339             }
340              
341             sub _slack_desc_header {
342 0     0     my ( $self, $indentation_level ) = @_;
343              
344 0           my $tab = q{ } x $indentation_level;
345              
346 0           return <<"END_DESC";
347             # HOW TO EDIT THIS FILE:
348             # The "handy ruler" below makes it easier to edit a package description. Line
349             # up the first '|' above the ':' following the base package name, and the '|'
350             # on the right side marks the last column you can put a character in. You must
351             # make exactly 11 lines for the formatting to be correct. It's also
352             # customary to leave one space after the ':'.
353              
354             $tab|-----handy-ruler------------------------------------------------------|
355             END_DESC
356             }
357              
358             sub slack_desc {
359 0     0 1   my $self = shift;
360              
361 0           my $name = $self->normalized_name;
362 0           my $prefix = "$name:";
363 0           my $title = "$prefix $name";
364 0           my $summary = $self->summary;
365 0           my $webpage = $self->_webpage;
366              
367             # Format the summary.
368 0           my $tab = "$prefix ";
369 0           $columns = 71 + length $tab;
370 0           my $body = Text::Wrap::wrap( $tab, $tab, $summary );
371              
372 0           my $max_body_line_count = 9; # 11 - 2
373              
374             # How long in lines is the formatted text?
375 0           my $body_line_count = @{ [ $body =~ /^\Q$tab\E/mg ] };
  0            
376 0 0         if ( $body_line_count < $max_body_line_count ) {
    0          
377              
378             # Add the distribution's webpage if there is enough space left.
379 0           my $link = Text::Wrap::wrap( $tab, $tab,
380             "For more info, visit: $webpage" );
381 0           my $link_line_count = @{ [ $link =~ /^\Q$tab\E/mg ] };
  0            
382 0 0         if ( $body_line_count + $link_line_count < $max_body_line_count ) {
383 0 0         if ( $body_line_count > 0 ) {
384              
385             # Insert an empty line between the summary and the link.
386 0           $body .= "\n$prefix\n";
387 0           ++$body_line_count;
388             }
389 0           $body .= $link;
390 0           $body_line_count += $link_line_count;
391             }
392              
393             # Add empty lines if necessary.
394 0           $body .= "\n$prefix" x ( $max_body_line_count - $body_line_count );
395             }
396             elsif ( $body_line_count > $max_body_line_count ) {
397              
398             # Cut the summary if it is too long.
399 0           $body = join "\n",
400             ( split /\n/, $body )[ 0 .. $max_body_line_count - 1 ];
401             }
402             return
403 0           $self->_slack_desc_header( length $name )
404             . "$title\n"
405             . "$prefix\n"
406             . "$body\n";
407             }
408              
409             sub build_script {
410 0     0 1   my $self = shift;
411 0           my $module = $self->module;
412 0           my $name = $module->package_name;
413 0           my $version = $module->package_version;
414 0           my $installdirs = $self->installdirs;
415              
416             # Quote single quotes.
417 0           $name =~ s/('+)/'"$1"'/g;
418 0           $version =~ s/('+)/'"$1"'/g;
419              
420 0           return <<"END_SCRIPT";
421             #!/bin/sh
422             SRCNAM='$name'
423             VERSION=\${VERSION:-'$version'}
424             INSTALLDIRS=\${INSTALLDIRS:-$installdirs}
425             cpan2dist --format CPANPLUS::Dist::Slackware --dist-opts installdirs=\$INSTALLDIRS \$SRCNAM-\$VERSION
426             END_SCRIPT
427             }
428              
429             sub _prereqs {
430 0     0     my $self = shift;
431 0           my $module = $self->module;
432 0           my $cb = $module->parent;
433              
434 0           my $perl_version = version->parse($PERL_VERSION);
435 0           my %prereqs;
436 0           my $prereq_ref = $module->status->prereqs;
437 0 0         if ($prereq_ref) {
438 0           for my $srcname ( keys %{$prereq_ref} ) {
  0            
439 0           my $modobj = $cb->module_tree($srcname);
440 0 0         next if !$modobj;
441              
442             # Don't list core modules as prerequisites.
443 0 0         next if $modobj->package_is_perl_core;
444              
445             # Task::Weaken is only a build dependency.
446 0 0         next if $modobj->package_name eq 'Task-Weaken';
447              
448             # Omit modules that are distributed with Perl.
449 0           my $version = $prereq_ref->{$srcname};
450 0           my $s = Module::CoreList->removed_from($srcname);
451 0 0 0       if ( !defined $s || $perl_version < version->parse($s) ) {
452             ## cpan2dist is run with -w, which triggers a warning in
453             ## Module::CoreList.
454 0           local $WARNING = 0;
455 0           my $r = Module::CoreList->first_release( $srcname, $version );
456 0 0 0       next if defined $r && version->parse($r) <= $perl_version;
457             }
458              
459 0           my $name = _normalize_name( $modobj->package_name );
460 0 0 0       if ( !exists $prereqs{$name}
461             || version->parse( $prereqs{$name} )
462             < version->parse($version) )
463             {
464 0           $prereqs{$name} = $version;
465             }
466             }
467             }
468             my @prereqs
469 0           = map { { name => $_, version => _normalize_version( $prereqs{$_} ) } }
470 0           sort { uc $a cmp uc $b } keys %prereqs;
  0            
471 0           return @prereqs;
472             }
473              
474             sub readme_slackware {
475 0     0 1   my $self = shift;
476 0           my $module = $self->module;
477 0           my $name = $module->package_name;
478 0           my $version = $module->package_version;
479              
480 0           $columns = 78;
481              
482 0           my $title = "$name for Slackware Linux";
483 0           my $line = q{=} x length $title;
484 0           my $readme = "$title\n$line\n\n";
485              
486 0           my @prereqs = $self->_prereqs;
487              
488 0           my $text = 'This package was created by CPANPLUS::Dist::Slackware'
489             . " from the Perl distribution '$name' version $version.";
490 0           $readme .= Text::Wrap::wrap( q{}, q{}, $text ) . "\n";
491              
492 0 0         if (@prereqs) {
493 0           $readme
494             .= "\n"
495             . "Required modules\n"
496             . "----------------\n\n"
497             . "The following Perl packages are required:\n\n";
498 0           for my $prereq (@prereqs) {
499 0           my $prereq_name = $prereq->{name};
500 0           my $prereq_version = $prereq->{version};
501 0           $readme .= "* $prereq_name";
502 0 0         if ( $prereq_version ne '0' ) {
503 0           $readme .= " >= $prereq_version";
504             }
505 0           $readme .= "\n";
506             }
507             }
508              
509 0           return $readme;
510             }
511              
512             sub destdir {
513 0     0 1   my $self = shift;
514              
515 0           my $module = $self->module;
516 0           my $cb = $module->parent;
517 0           my $destdir = $self->{destdir};
518 0 0         if ( !$destdir ) {
519 0           my $template = 'package-' . $self->normalized_name . '-XXXXXXXXXX';
520 0   0       my $wrkdir = $ENV{TMP} || catdir( tmpdir(), 'CPANPLUS' );
521 0 0         if ( !-d $wrkdir ) {
522 0 0         $cb->_mkdir( dir => $wrkdir )
523             or die "Could not create directory '$wrkdir': $OS_ERROR\n";
524             }
525 0           $destdir = File::Temp::tempdir( $template, DIR => $wrkdir );
526 0 0         chmod oct '0755', $destdir
527             or die "Could not chmod '$destdir': $OS_ERROR\n";
528 0           $self->{destdir} = $destdir;
529             }
530 0           return $destdir;
531             }
532              
533             1;
534             __END__