]> git.vpit.fr Git - perl/modules/CPANPLUS-Dist-Gentoo.git/blob - lib/CPANPLUS/Dist/Gentoo.pm
This is 0.04
[perl/modules/CPANPLUS-Dist-Gentoo.git] / lib / CPANPLUS / Dist / Gentoo.pm
1 package CPANPLUS::Dist::Gentoo;
2
3 use strict;
4 use warnings;
5
6 use File::Copy qw/copy/;
7 use File::Path qw/mkpath/;
8 use File::Spec::Functions qw/catdir catfile/;
9
10 use IPC::Cmd qw/run can_run/;
11
12 use CPANPLUS::Error;
13
14 use base qw/CPANPLUS::Dist::Base/;
15
16 =head1 NAME
17
18 CPANPLUS::Dist::Gentoo - CPANPLUS backend generating Gentoo ebuilds.
19
20 =head1 VERSION
21
22 Version 0.04
23
24 =cut
25
26 our $VERSION = '0.04';
27
28 =head1 SYNOPSIS
29
30     cpan2dist --format=CPANPLUS::Dist::Gentoo \
31               --dist-opts overlay=/usr/local/portage \
32               --dist-opts distdir=/usr/portage/distfiles \
33               --dist-opts manifest=yes \
34               --dist-opts keywords=x86 \
35               --dist-opts header="# Copyright 1999-2008 Gentoo Foundation" \
36               --dist-opts footer="# End" \
37               Any::Module You::Like
38
39 =head1 DESCRPITON
40
41 This module is a CPANPLUS backend that recursively generates Gentoo ebuilds for a given package in the specified overlay (defaults to F</usr/local/portage>), updates the manifest, and even emerges it (together with its dependencies) if the user requires it. You need write permissions on the directory where Gentoo fetches its source files (usually F</usr/portage/distfiles>). You also need to specify the correct keyword for your architecture if it differs from the default C<x86>.
42
43 The generated ebuilds are placed into the C<perl-gcpanp> category. They favour depending on C<perl-core>, C<dev-perl> or C<perl-gcpan> (in that order) rather than C<perl-gcpanp>.
44
45 =head1 INSTALLATION
46
47 After installing this module, you should append C<perl-gcpanp> to your F</etc/portage/categories> file.
48
49 =head1 METHODS
50
51 All the methods are inherited from L<CPANPLUS::Dist::Base>. Please refer to its documentation for precise information on what's done at each step.
52
53 =cut
54
55 use constant CATEGORY => 'perl-gcpanp';
56
57 sub format_available {
58  for my $prog (qw/emerge ebuild/) {
59   unless (can_run($prog)) {
60    error "$prog is required to write ebuilds -- aborting";
61    return 0;
62   }
63  }
64  return 1;
65 }
66
67 sub init {
68  my ($self) = @_;
69  my $stat = $self->status;
70  my $conf = $self->parent->parent->configure_object;
71
72  $stat->mk_accessors(qw/name version author dist desc uri src license deps
73                         eb_name eb_version eb_dir eb_file fetched_arch
74                         overlay distdir keywords do_manifest header footer
75                         force verbose/);
76
77  $stat->force($conf->get_conf('force'));
78  $stat->verbose($conf->get_conf('verbose'));
79
80  return 1;
81 }
82
83 my %gentooism = (
84  'Digest'            => 'digest-base',
85  'Locale-Maketext'   => 'locale-maketext',
86  'Net-Ping'          => 'net-ping',
87  'PathTools'         => 'File-Spec',
88  'PodParser'         => 'Pod-Parser',
89  'Set-Scalar'        => 'set-scalar',
90  'Tie-EncryptedHash' => 'tie-encryptedhash',
91 );
92
93 sub prepare {
94  my $self = shift;
95  my $mod  = $self->parent;
96  my $stat = $self->status;
97  my $int  = $mod->parent;
98  my $conf = $int->configure_object;
99
100  my %opts = @_;
101
102  my $keywords = delete $opts{'keywords'};
103  $keywords = 'x86' unless defined $keywords;
104  $keywords = [ split ' ', $keywords ];
105  $stat->keywords($keywords);
106
107  my $manifest = delete $opts{'manifest'};
108  $manifest = 1 unless defined $manifest;
109  $manifest = 0 if $manifest =~ /^\s*no?\s*$/i;
110  $stat->do_manifest($manifest);
111
112  my $header = delete $opts{'header'};
113  if (defined $header) {
114   1 while chomp $header;
115   $header .= "\n\n";
116  } else {
117   $header = '';
118  }
119  $stat->header($header);
120
121  my $footer = delete $opts{'footer'};
122  if (defined $footer) {
123   $footer = "\n" . $footer;
124  } else {
125   $footer = '';
126  }
127  $stat->footer($footer);
128
129  $stat->overlay(delete($opts{'overlay'}) || '/usr/local/portage');
130
131  $stat->distdir(delete($opts{'distdir'}) || '/usr/portage/distfiles');
132
133  if ($stat->do_manifest && !-w $stat->distdir) {
134   error 'distdir isn\'t writable -- aborting';
135   return 0;
136  }
137  $stat->fetched_arch($mod->status->fetch);
138
139  my $name = $mod->package_name;
140  $stat->name($name);
141
142  my $version = $mod->package_version;
143  $stat->version($version);
144
145  my $author = $mod->author->cpanid;
146  $stat->author($author);
147
148  $stat->dist($name . '-' . $version);
149
150  $version =~ s/[^\d._]+//g;
151  $version =~ s/^[._]*//;
152  $version =~ s/[._]*$//;
153  $version =~ s/[._]*_[._]*/_/g;
154  {
155   ($version, my $patch, my @rest) = split /_/, $version;
156   $version .= '_p' . $patch if defined $patch;
157   $version .= join('.', '', @rest) if @rest;
158  }
159  $stat->eb_version($version);
160
161  $stat->eb_name($gentooism{$name} || $name);
162
163  $stat->eb_dir(catdir($stat->overlay, CATEGORY, $stat->eb_name));
164
165  my $file = catfile($stat->eb_dir,
166                     $stat->eb_name . '-' . $stat->eb_version . '.ebuild');
167  if (-e $file) {
168   my $skip = 1;
169   if ($stat->force) {
170    if (-w $file) {
171     1 while unlink $file;
172     $skip = 0;
173    } else {
174     error "Can't force rewriting of $file -- skipping";
175    }
176   } else {
177    msg 'Ebuild already generated for ' . $stat->dist . ' -- skipping';
178   }
179   if ($skip) {
180    $stat->prepared(1);
181    $stat->created(1);
182    return 1;
183   }
184  }
185  $stat->eb_file($file);
186
187  $self->SUPER::prepare(%opts);
188
189  my $desc = $mod->description;
190  ($desc = $name) =~ s/-+/::/g unless $desc;
191  $stat->desc($desc);
192
193  $stat->uri('http://search.cpan.org/dist/' . $name);
194
195  unless ($author =~ /^(.)(.)/) {
196   error 'Wrong author name -- aborting';
197   return 0;
198  }
199  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/"
200             . $mod->package);
201
202  $stat->license([ qw/Artistic GPL-2/ ]);
203
204  my $prereqs = $mod->status->prereqs;
205  $prereqs = { map { ($gentooism{$_} || $_) => $prereqs->{$_} } keys %$prereqs };
206  my @depends;
207  for my $prereq (sort keys %$prereqs) {
208   next if $prereq =~ /^perl(?:-|\z)/;
209   my $obj = $int->module_tree($prereq);
210   unless ($obj) {
211    error 'Wrong module object -- aborting';
212    return 0;
213   }
214   next if $obj->package_is_perl_core;
215   {
216    my $version;
217    if ($prereqs->{$prereq}) {
218     if ($obj->installed_version && $obj->installed_version < $obj->version) {
219      $version = $obj->installed_version;
220     } else {
221      $version = $obj->package_version;
222     }
223    }
224    push @depends, [ $obj , $version ];
225   }
226  }
227  $stat->deps(\@depends);
228
229  return 1;
230 }
231
232 sub create {
233  my $self = shift;
234  my $stat = $self->status;
235
236  unless ($stat->prepared) {
237   error 'Can\'t create ' . $stat->dist . ' since it was never prepared -- aborting';
238   return 0;
239  }
240
241  if ($stat->created) {
242   msg $stat->dist . ' was already created -- skipping';
243   return 1;
244  }
245
246  $self->SUPER::create(@_);
247
248  my $dir = $stat->eb_dir;
249  unless (-d $dir) {
250   eval { mkpath $dir };
251   if ($@) {
252    error "mkpath($dir): $@";
253    return 0;
254   }
255  }
256
257  my $d = $stat->header;
258  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
259  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
260  $d   .= 'S="${WORKDIR}/' . $stat->dist . "\"\n";
261  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
262  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
263  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
264  $d   .= "SLOT=\"0\"\n";
265  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
266  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
267  $d   .= 'DEPEND="' . join "\n",
268   'dev-lang/perl',
269   map {
270    my $a = $_->[0]->package_name;
271    my $x = '';
272    if (defined $_->[1]) {
273     $x  = '>=';
274     $a .= '-' . $_->[1];
275    }
276    '|| ( ' . join(' ', map "$x$_/$a",
277                            qw/perl-core dev-perl perl-gcpan/, CATEGORY)
278            . ' )';
279   } @{$stat->deps};
280  $d   .= "\"\n";
281  $d   .= "SRC_TEST=\"do\"\n";
282  $d   .= $stat->footer;
283
284  my $file = $stat->eb_file;
285  open my $eb, '>', $file or do {
286   error "open($file): $! -- aborting";
287   return 0;
288  };
289  print $eb $d;
290  close $eb;
291
292  if ($stat->do_manifest) {
293   unless (copy $stat->fetched_arch, $stat->distdir) {
294    error "Couldn\'t copy the distribution file to distdir ($!) -- aborting";
295    1 while unlink $file;
296    return 0;
297   }
298
299   msg 'Adding Manifest entry for ' . $stat->dist;
300   unless ($self->_run([ 'ebuild', $file, 'manifest' ], 0)) {
301    1 while unlink $file;
302    return 0;
303   }
304  }
305
306  return 1;
307 }
308
309 sub install {
310  my $self = shift;
311  my $stat = $self->status;
312  my $conf = $self->parent->parent->configure_object;
313
314  my $sudo = $conf->get_program('sudo');
315  my @cmd = ('emerge', '=' . $stat->eb_name . '-' . $stat->eb_version);
316  unshift @cmd, $sudo if $sudo;
317
318  return $self->_run(\@cmd, 1);
319 }
320
321 sub uninstall {
322  my $self = shift;
323  my $stat = $self->status;
324  my $conf = $self->parent->parent->configure_object;
325
326  my $sudo = $conf->get_program('sudo');
327  my @cmd = ('emerge', '-C', '=' . $stat->eb_name . '-' . $stat->eb_version);
328  unshift @cmd, $sudo if $sudo;
329
330  return $self->_run(\@cmd, 1);
331 }
332
333 sub _run {
334  my ($self, $cmd, $verbose) = @_;
335  my $stat = $self->status;
336
337  my ($success, $errmsg, $output) = do {
338   local $ENV{PORTDIR_OVERLAY}     = $stat->overlay;
339   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
340   run command => $cmd, verbose => $verbose;
341  };
342
343  unless ($success) {
344   error "$errmsg -- aborting";
345   if (not $verbose and defined $output and $self->status->verbose) {
346    my $msg = join '', @$output;
347    1 while chomp $msg;
348    error $msg;
349   }
350  }
351
352  return $success;
353 }
354
355 =head1 DEPENDENCIES
356
357 Gentoo (L<http://gentoo.org>).
358
359 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5).
360
361 L<File::Path> (since 5.001), L<File::Copy> (5.002), L<File::Spec::Functions> (5.00504).
362
363 =head1 SEE ALSO
364
365 L<cpan2dist>.
366
367 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
368
369 =head1 AUTHOR
370
371 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
372
373 You can contact me by mail or on C<irc.perl.org> (vincent).
374
375 =head1 BUGS
376
377 Please report any bugs or feature requests to C<bug-cpanplus-dist-gentoo at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPANPLUS-Dist-Gentoo>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
378
379 =head1 SUPPORT
380
381 You can find documentation for this module with the perldoc command.
382
383     perldoc CPANPLUS::Dist::Gentoo
384
385 =head1 ACKNOWLEDGEMENTS
386
387 The module is to some extend cargo-culted from L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
388
389 Kent Fredric, for testing and suggesting improvements.
390
391 =head1 COPYRIGHT & LICENSE
392
393 Copyright 2008 Vincent Pit, all rights reserved.
394
395 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
396
397 =cut
398
399 1; # End of CPANPLUS::Dist::Gentoo