lib/App/CPAN2Pkg/Module.pm

   1 #
   2 # This file is part of App::CPAN2Pkg.
   3 # Copyright (c) 2009 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package App::CPAN2Pkg::Module;
  11
  12 use 5.010;
  13 use strict;
  14 use warnings;
  15
  16 use Class::XSAccessor
  17     constructor => '_new',
  18     accessors   => {
  19         name      => 'name',
  20         _output    => '_output',
  21         _prereqs   => '_prereqs',
  22         _rpm       => '_rpm',
  23         _srpm      => '_srpm',
  24         _wheel     => '_wheel',
  25     };
  26 use List::MoreUtils qw{ firstidx };
  27 use POE;
  28 use POE::Filter::Line;
  29 use POE::Wheel::Run;
  30
  31 my $rpm_locked = '';   # only one rpm transaction at a time
  32
  33
  34 # on debian / ubuntu
  35 # $ apt-file find Audio/MPD.pm
  36 # libaudio-mpd-perl: /usr/share/perl5/Audio/MPD.pm
  37 # status:
  38 # - find dist hosting module
  39 #  - computing dependencies
  40 #  - installing dependencies
  41 #  - check cooker availability
  42 #  - cpan2dist
  43 #  - install local
  44 #  - check local availability
  45 #  - mdvsys import
  46 #  - mdvsys submit
  47 #  - wait for kenobi build
  48 #
  49
  50
  51
  52
  53 #--
  54 # CONSTRUCTOR
  55
  56 sub spawn {
  57     my ($class, $name) = @_;
  58
  59     # creating the object
  60     my $obj = App::CPAN2Pkg::Module->_new(
  61         name      => $name,
  62         _prereqs  => [],
  63         _wheel    => undef,
  64     );
  65
  66     # spawning the session
  67     my $session = POE::Session->create(
  68         inline_states => {
  69             # public events
  70             cpan2dist          => \&cpan2dist,
  71             find_prereqs       => \&find_prereqs,
  72             install_from_dist  => \&install_from_dist,
  73             install_from_local => \&install_from_local,
  74             is_in_dist         => \&is_in_dist,
  75             is_installed       => \&is_installed,
  76             # private events
  77             _cpan2dist          => \&_cpan2dist,
  78             _find_prereqs       => \&_find_prereqs,
  79             _install_from_dist  => \&_install_from_dist,
  80             _install_from_local => \&_install_from_local,
  81             _is_in_dist         => \&_is_in_dist,
  82             _stderr             => \&_stderr,
  83             _stdout             => \&_stdout,
  84             # poe inline states
  85             _start => \&_start,
  86             #_stop  => sub { warn "stop " . $_[HEAP]->name . "\n"; },
  87         },
  88         heap => $obj,
  89     );
  90     return $session->ID;
  91 }
  92
  93
  94 #--
  95 # SUBS
  96
  97 # -- public events
  98
  99 sub cpan2dist {
 100     my ($k, $self) = @_[KERNEL, HEAP];
 101
 102     # we don't want to re-build the prereqs, even if we're not at their
 103     # most recent version. and cpanplus --nobuildprereqs does not work
 104     # as one thinks (it's "don't rebuild prereqs if we're at latest version,
 105     # but rebuild anyway if we're not at latest version").
 106     # and somehow, the ignore list with regex /(?<!$name)$/ does not work.
 107     # so we're stuck with ignore modules one by one - sigh.
 108     my $ignore = '';
 109     $ignore .= "--ignore '^$_\$' " foreach @{ $self->_prereqs };
 110
 111     # preparing command. note that we do want --force, to be able to extract
 112     # the rpm and srpm pathes from the output.
 113     my $name = $self->name;
 114     my $cmd = "cpan2dist $ignore --force --format=CPANPLUS::Dist::Mdv $name";
 115     $self->_log_new_step('Building package', "Running command: $cmd" );
 116
 117     # running command
 118     $self->_output('');
 119     $ENV{LC_ALL} = 'C';
 120     my $wheel = POE::Wheel::Run->new(
 121         Program      => $cmd,
 122         CloseEvent   => '_cpan2dist',
 123         StdoutEvent  => '_stdout',
 124         StderrEvent  => '_stderr',
 125         StdoutFilter => POE::Filter::Line->new,
 126         StderrFilter => POE::Filter::Line->new,
 127     );
 128
 129     # need to store the wheel, otherwise the process goes woo!
 130     $self->_wheel($wheel);
 131 }
 132
 133 sub find_prereqs {
 134     my ($k, $self) = @_[KERNEL, HEAP];
 135
 136     # preparing command
 137     my $name = $self->name;
 138     my $cmd = "cpanp /prereqs show $name";
 139     $self->_log_new_step('Finding module prereqs', "Running command: $cmd" );
 140
 141     # running command
 142     $self->_output('');
 143     $ENV{LC_ALL} = 'C';
 144     my $wheel = POE::Wheel::Run->new(
 145         Program      => $cmd,
 146         CloseEvent   => '_find_prereqs',
 147         StdoutEvent  => '_stdout',
 148         StderrEvent  => '_stderr',
 149         StdoutFilter => POE::Filter::Line->new,
 150         StderrFilter => POE::Filter::Line->new,
 151     );
 152
 153     # need to store the wheel, otherwise the process goes woo!
 154     $self->_wheel($wheel);
 155 }
 156
 157 sub install_from_dist {
 158     my ($k, $self) = @_[KERNEL, HEAP];
 159     my $name = $self->name;
 160
 161     # check whether there's another rpm transaction
 162     if ( $rpm_locked ) {
 163         $self->_log_prefixed_lines("waiting for rpm lock... (owned by $rpm_locked)");
 164         $k->delay( install_from_dist => 1 );
 165         return;
 166     }
 167     $rpm_locked = $name;
 168
 169     # preparing command
 170     my $cmd  = "sudo urpmi --auto 'perl($name)'";
 171     $self->_log_new_step('Installing from upstream', "Running command: $cmd" );
 172
 173     # running command
 174     $self->_output('');
 175     $ENV{LC_ALL} = 'C';
 176     my $wheel = POE::Wheel::Run->new(
 177         Program      => $cmd,
 178         StdoutEvent  => '_stdout',
 179         StderrEvent  => '_stderr',
 180         Conduit      => 'pty-pipe', # urpmi wants a pty
 181         StdoutFilter => POE::Filter::Line->new,
 182         StderrFilter => POE::Filter::Line->new,
 183     );
 184     $k->sig( CHLD => '_install_from_dist' );
 185
 186     # need to store the wheel, otherwise the process goes woo!
 187     $self->_wheel($wheel);
 188 }
 189
 190 sub install_from_local {
 191     my ($k, $self) = @_[KERNEL, HEAP];
 192     my $name = $self->name;
 193
 194     # check whether there's another rpm transaction
 195     if ( $rpm_locked ) {
 196         $self->_log_prefixed_lines("waiting for rpm lock... (owned by $rpm_locked)");
 197         $k->delay( install_from_local => 1 );
 198         return;
 199     }
 200     $rpm_locked = $name;
 201
 202     # preparing command
 203     my $rpm = $self->_rpm;
 204     my $cmd = "sudo rpm -Uv $rpm";
 205     $self->_log_new_step('Installing from local', "Running command: $cmd" );
 206
 207     # running command
 208     $self->_output('');
 209     $ENV{LC_ALL} = 'C';
 210     my $wheel = POE::Wheel::Run->new(
 211         Program      => $cmd,
 212         StdoutEvent  => '_stdout',
 213         StderrEvent  => '_stderr',
 214         StdoutFilter => POE::Filter::Line->new,
 215         StderrFilter => POE::Filter::Line->new,
 216     );
 217     $k->sig( CHLD => '_install_from_local' );
 218
 219     # need to store the wheel, otherwise the process goes woo!
 220     $self->_wheel($wheel);
 221 }
 222
 223 sub is_in_dist {
 224     my ($k, $self) = @_[KERNEL, HEAP];
 225
 226     # preparing command
 227     my $name = $self->name;
 228     my $cmd  = "urpmq --whatprovides 'perl($name)'";
 229     $self->_log_new_step('Checking if packaged upstream', "Running command: $cmd" );
 230
 231     # running command
 232     $self->_output('');
 233     $ENV{LC_ALL} = 'C';
 234     my $wheel = POE::Wheel::Run->new(
 235         Program      => $cmd,
 236         #CloseEvent   => '_is_in_dist', # FIXME: cf rt#42757
 237         StdoutEvent  => '_stdout',
 238         StderrEvent  => '_stderr',
 239         Conduit      => 'pty-pipe', # urpmq wants a pty
 240         StdoutFilter => POE::Filter::Line->new,
 241         StderrFilter => POE::Filter::Line->new,
 242     );
 243     $k->sig( CHLD => '_is_in_dist' );
 244
 245     # need to store the wheel, otherwise the process goes woo!
 246     $self->_wheel($wheel);
 247 }
 248
 249
 250 sub is_installed {
 251     my ($k, $self) = @_[KERNEL, HEAP];
 252
 253     my $name = $self->name;
 254     my $cmd  = qq{ require $name };
 255     $self->_log_new_step(
 256         'Checking if module is installed',
 257         "Evaluating command: $cmd"
 258     );
 259
 260     eval $cmd;
 261     my $what = $@ || "$name loaded successfully\n";
 262     $k->post('ui', 'append', $self, $what);
 263
 264     my $is_installed = $@ eq '';
 265     my $status = $is_installed ? 'installed' : 'not installed';
 266     $self->_log_result("$name is $status locally.");
 267     $k->post('app', 'local_status', $self, $is_installed);
 268 }
 269
 270 # -- private events
 271
 272 sub _cpan2dist {
 273     my ($k, $self, $id) = @_[KERNEL, HEAP, ARG0];
 274     my $name = $self->name;
 275
 276     # terminate wheel
 277     my $wheel  = $self->_wheel;
 278     $self->_wheel(undef);
 279
 280     # check whether the package has been built correctly.
 281     my $output = $self->_output;
 282     my ($rpm, $srpm);
 283     $rpm  = $1 if $output =~ /rpm created successfully: (.*\.rpm)/;
 284     $srpm = $1 if $output =~ /srpm available: (.*\.src.rpm)/;
 285
 286     my ($status, @result);
 287     if ( $rpm && $srpm ) {
 288         $status = 1;
 289         @result = (
 290             "$name has been successfully built",
 291             "srpm created: $srpm",
 292             "rpm created:  $rpm",
 293         );
 294
 295         # storing path to interesting files
 296         $self->_rpm($rpm);
 297         $self->_srpm($srpm);
 298
 299     } else {
 300         $status = 0;
 301         @result = ( "error while building $name" );
 302     }
 303
 304     # update main application
 305     $self->_log_result(@result);
 306     $k->post('app', 'cpan2dist_status', $self, $status);
 307 }
 308
 309 sub _find_prereqs {
 310     my ($k, $self, $id) = @_[KERNEL, HEAP, ARG0];
 311
 312     # terminate wheel
 313     my $wheel  = $self->_wheel;
 314     $self->_wheel(undef);
 315
 316     # extract prereqs
 317     my @lines   = split /\n/, $self->_output;
 318     my @tabbed  = grep { s/^\s+// } @lines;
 319     my $idx     = firstidx { /^Module\s+Req Ver.*Satisfied/ } @tabbed;
 320     my @wanted  = @tabbed[ $idx+1 .. $#tabbed ];
 321     my @prereqs = map  { (split /\s+/, $_)[0] } @wanted;
 322
 323     # store prereqs
 324     $self->_prereqs( \@prereqs );
 325     my @logs = @prereqs
 326         ? map { "prereq found: $_" } @prereqs
 327         : 'No prereqs found.';
 328     $self->_log_result(@logs);
 329     $k->post('app', 'prereqs', $self, @prereqs);
 330 }
 331
 332 sub _install_from_dist {
 333     my($k, $self, $pid, $rv) = @_[KERNEL, HEAP, ARG1, ARG2];
 334
 335     # since it's a sigchld handler, it also gets called for other
 336     # spawned processes. therefore, screen out processes that are
 337     # not related to this object.
 338     return unless defined $self->_wheel;
 339     return unless $self->_wheel->PID == $pid;
 340
 341     # terminate wheel
 342     $self->_wheel(undef);
 343
 344     # release rpm lock
 345     $rpm_locked = '';
 346
 347     # log result
 348     my $name  = $self->name;
 349     my $exval = $rv >> 8;
 350     my $status = $exval ? 'not been' : 'been';
 351     $self->_log_result( "$name has $status installed from upstream." );
 352     $k->post('app', 'upstream_install', $self, !$exval);
 353 }
 354
 355
 356 sub _install_from_local {
 357     my($k, $self, $pid, $rv) = @_[KERNEL, HEAP, ARG1, ARG2];
 358
 359     # since it's a sigchld handler, it also gets called for other
 360     # spawned processes. therefore, screen out processes that are
 361     # not related to this object.
 362     return unless defined $self->_wheel;
 363     return unless $self->_wheel->PID == $pid;
 364
 365     # terminate wheel
 366     $self->_wheel(undef);
 367
 368     # release rpm lock
 369     $rpm_locked = '';
 370
 371     # log result
 372     my $name  = $self->name;
 373     my $rpm   = $self->_rpm;
 374     my $exval = $rv >> 8;
 375     my $status = $exval ? 'not been' : 'been';
 376     $self->_log_result( "$name has $status installed from $rpm." );
 377     $k->post('app', 'local_install', $self, !$exval);
 378 }
 379
 380
 381 sub _is_in_dist {
 382     my($k, $self, $pid, $rv) = @_[KERNEL, HEAP, ARG1, ARG2];
 383
 384     # since it's a sigchld handler, it also gets called for other
 385     # spawned processes. therefore, screen out processes that are
 386     # not related to this object.
 387     return unless defined $self->_wheel;
 388     return unless $self->_wheel->PID == $pid;
 389
 390     # terminate wheel
 391     # FIXME: should be done in CloseEvent
 392     $self->_wheel(undef);
 393
 394     # check if we got a hit
 395     # urpmq returns 0 if found, 1 otherwise.
 396     my $name  = $self->name;
 397     my $exval = $rv >> 8;
 398
 399     my $status = $exval ? 'not' : 'already';
 400     $self->_log_result( "$name is $status packaged upstream." );
 401     $k->post('app', 'upstream_status', $self, !$exval);
 402 }
 403
 404 sub _stderr {
 405     my ($k, $self, $line) = @_[KERNEL, HEAP, ARG0];
 406     $k->post('ui', 'append', $self, "stderr: $line\n");
 407 }
 408
 409 sub _stdout {
 410     my ($k, $self, $line) = @_[KERNEL, HEAP, ARG0];
 411     $line .= "\n";
 412     $self->_output( $self->_output . $line );
 413     $k->post('ui', 'append', $self, "stdout: $line");
 414 }
 415
 416
 417 # -- poe inline states
 418
 419 sub _start {
 420     my ($k, $self) = @_[KERNEL, HEAP];
 421
 422     $k->alias_set($self);
 423     $k->alias_set($self->name);
 424     $k->post('ui',  'module_spawned', $self);
 425     $k->post('app', 'module_spawned', $self);
 426 }
 427
 428
 429 #--
 430 # METHODS
 431
 432 # -- private methods
 433
 434 sub _log_empty_line {
 435     my ($self, $nb) = @_;
 436     $nb //= 1; #/ FIXME padre syntaxic color glitch
 437     POE::Kernel->post('ui', 'append', $self, "\n" x $nb);
 438 }
 439
 440 sub _log_prefixed_lines {
 441     my ($self, @lines) = @_;
 442
 443     my $prefix = '*';
 444     POE::Kernel->post('ui', 'append', $self, $_)
 445         for map { "$prefix $_\n" } @lines;
 446 }
 447
 448 sub _log_new_step {
 449     my ($self, $step, $comment) = @_;
 450
 451     $self->_log_prefixed_lines('-' x 10, $step, '', $comment, '');
 452     $self->_log_empty_line;
 453 }
 454
 455 sub _log_result {
 456     my ($self, @lines) = @_;
 457
 458     $self->_log_empty_line;
 459     $self->_log_prefixed_lines( '', @lines, '', '' );
 460 }
 461
 462
 463 1;
 464 __END__
 465
 466
 467 =head1 NAME
 468
 469 App::CPAN2Pkg::Module - poe session to drive a module packaging
 470
 471
 472
 473 =head1 DESCRIPTION
 474
 475 C<App::CPAN2Pkg::Module> implements a POE session driving the whole
 476 packaging process of a given module.
 477
 478 It is spawned by C<App::CPAN2Pkg> and implements the logic related to
 479 the module availability in the distribution.
 480
 481
 482
 483 =head1 PUBLIC PACKAGE METHODS
 484
 485 =head2 my $id = App::CPAN2Pkg::Module->spawn( $module )
 486
 487 This method will create a POE session responsible for packaging &
 488 installing the wanted C<$module>.
 489
 490 It will return the POE id of the session newly created.
 491
 492
 493
 494 =head1 PUBLIC EVENTS ACCEPTED
 495
 496 =head2 cpan2dist()
 497
 498 Build a native package for this module, using C<cpan2dist> with the C<--force> flag.
 499
 500
 501 =head2 find_prereqs()
 502
 503 Start looking for any other module needed by current module.
 504
 505
 506 =head2 install_from_dist()
 507
 508 Try to install module from upstream distribution.
 509
 510
 511 =head2 install_from_local()
 512
 513 Try to install module from package freshly build.
 514
 515
 516 =head2 is_in_dist()
 517
 518 Check whether the package is provided by an existing upstream package.
 519
 520
 521 =head2 is_installed()
 522
 523 Check whether the package is installed locally.
 524
 525
 526 =head1 METHODS
 527
 528 This package is also a class, used B<internally> to store private data
 529 needed for the packaging stuff. The following accessors are therefore
 530 available, but should not be used directly:
 531
 532 =over 4
 533
 534 =item name() - the module name
 535
 536 =back
 537
 538
 539
 540 =head1 SEE ALSO
 541
 542 For all related information (bug reporting, source code repository,
 543 etc.), refer to C<App::CPAN2Pkg>'s pod, section C<SEE ALSO>.
 544
 545
 546
 547 =head1 AUTHOR
 548
 549 Jerome Quelin, C<< <jquelin@cpan.org> >>
 550
 551
 552
 553 =head1 COPYRIGHT & LICENSE
 554
 555 Copyright (c) 2009 Jerome Quelin, all rights reserved.
 556
 557 This program is free software; you can redistribute it and/or modify
 558 it under the same terms as Perl itself.
 559
 560 =cut
 561