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     accessors   => {
  18         # public
  19         is_local => 'is_local',  # if module is available locally
  20         name     => 'name',
  21         # private
  22         _blocking  => '_blocking',
  23         _missing   => '_missing',
  24         _output    => '_output',
  25         _pkgname   => '_pkgname',
  26         _prereqs   => '_prereqs',
  27         _rpm       => '_rpm',
  28         _srpm      => '_srpm',
  29         _wheel     => '_wheel',
  30     };
  31 use File::Basename  qw{ basename };
  32 use List::MoreUtils qw{ firstidx };
  33 use POE;
  34 use POE::Filter::Line;
  35 use POE::Wheel::Run;
  36
  37 my $rpm_locked = '';   # only one rpm transaction at a time
  38
  39
  40 # on debian / ubuntu
  41 # $ apt-file find Audio/MPD.pm
  42 # libaudio-mpd-perl: /usr/share/perl5/Audio/MPD.pm
  43 # status:
  44 # - find dist hosting module
  45 #  - computing dependencies
  46 #  - installing dependencies
  47 #  - check cooker availability
  48 #  - cpan2dist
  49 #  - install local
  50 #  - check local availability
  51 #  - mdvsys import
  52 #  - mdvsys submit
  53 #  - wait for kenobi build
  54 #
  55
  56
  57 sub new {
  58     my ($pkg, %params) = @_;
  59     my $self = {
  60         _blocking => {},
  61         _missing  => {},
  62         %params,
  63     };
  64     my $class = ref($pkg) || $pkg;
  65     bless $self, $class;
  66     return $self;
  67 }
  68
  69
  70 #--
  71 # SUBS
  72
  73 # -- public events
  74
  75 sub available_on_bs {
  76     my ($k, $self) = @_[KERNEL, OBJECT];
  77     $k->post('app', 'available_on_bs', $self);
  78 }
  79
  80 sub build_upstream {
  81     my ($k, $self) = @_[KERNEL, OBJECT];
  82
  83     # preparing command.
  84     my $name    = $self->name;
  85     my $pkgname = $self->_pkgname;
  86     my $cmd = "mdvsys submit $pkgname";
  87     $self->_log_new_step('Submitting package upstream', "Running command: $cmd" );
  88
  89     # running command
  90     $self->_output('');
  91     $ENV{LC_ALL} = 'C';
  92     my $wheel = POE::Wheel::Run->new(
  93         Program      => $cmd,
  94         StdoutEvent  => '_stdout',
  95         StderrEvent  => '_stderr',
  96         StdoutFilter => POE::Filter::Line->new,
  97         StderrFilter => POE::Filter::Line->new,
  98     );
  99     $k->sig( CHLD => '_build_upstream' );
 100
 101     # need to store the wheel, otherwise the process goes woo!
 102     $self->_wheel($wheel);
 103 }
 104
 105 sub cpan2dist {
 106     my ($k, $self) = @_[KERNEL, OBJECT];
 107
 108     # we don't want to re-build the prereqs, even if we're not at their
 109     # most recent version. and cpanplus --nobuildprereqs does not work
 110     # as one thinks (it's "don't rebuild prereqs if we're at latest version,
 111     # but rebuild anyway if we're not at latest version").
 112     # and somehow, the ignore list with regex /(?<!$name)$/ does not work.
 113     # so we're stuck with ignore modules one by one - sigh.
 114     my $ignore = '';
 115     $ignore .= "--ignore '^$_\$' " foreach @{ $self->_prereqs };
 116
 117     # preparing command. note that we do want --force, to be able to extract
 118     # the rpm and srpm pathes from the output.
 119     my $name = $self->name;
 120     my $cmd = "cpan2dist $ignore --force --format=CPANPLUS::Dist::Mdv $name";
 121     $self->_log_new_step('Building package', "Running command: $cmd" );
 122
 123     # running command
 124     $self->_output('');
 125     $ENV{LC_ALL} = 'C';
 126     my $wheel = POE::Wheel::Run->new(
 127         Program      => $cmd,
 128         CloseEvent   => '_cpan2dist',
 129         StdoutEvent  => '_stdout',
 130         StderrEvent  => '_stderr',
 131         StdoutFilter => POE::Filter::Line->new,
 132         StderrFilter => POE::Filter::Line->new,
 133     );
 134
 135     # need to store the wheel, otherwise the process goes woo!
 136     $self->_wheel($wheel);
 137 }
 138
 139
 140 sub import_upstream {
 141 return;
 142     my ($k, $self) = @_[KERNEL, OBJECT];
 143
 144     # preparing command.
 145     my $name = $self->name;
 146     my $srpm = $self->_srpm;
 147     my $cmd = "mdvsys import $srpm";
 148     $self->_log_new_step('Importing package upstream', "Running command: $cmd" );
 149
 150     # running command
 151     $self->_output('');
 152     $ENV{LC_ALL} = 'C';
 153     my $wheel = POE::Wheel::Run->new(
 154         Program      => $cmd,
 155         StdoutEvent  => '_stdout',
 156         StderrEvent  => '_stderr',
 157         StdoutFilter => POE::Filter::Line->new,
 158         StderrFilter => POE::Filter::Line->new,
 159     );
 160     $k->sig( CHLD => '_import_upstream' );
 161
 162     # need to store the wheel, otherwise the process goes woo!
 163     $self->_wheel($wheel);
 164 }
 165
 166 sub find_prereqs {
 167     my ($k, $self) = @_[KERNEL, OBJECT];
 168
 169     # preparing command
 170     my $name = $self->name;
 171     my $cmd = "cpanp /prereqs show $name";
 172     $self->_log_new_step('Finding module prereqs', "Running command: $cmd" );
 173
 174     # running command
 175     $self->_output('');
 176     $ENV{LC_ALL} = 'C';
 177     my $wheel = POE::Wheel::Run->new(
 178         Program      => $cmd,
 179         CloseEvent   => '_find_prereqs',
 180         StdoutEvent  => '_stdout',
 181         StderrEvent  => '_stderr',
 182         StdoutFilter => POE::Filter::Line->new,
 183         StderrFilter => POE::Filter::Line->new,
 184     );
 185
 186     # need to store the wheel, otherwise the process goes woo!
 187     $self->_wheel($wheel);
 188 }
 189
 190 sub install_from_dist {
 191     my ($k, $self) = @_[KERNEL, OBJECT];
 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_dist => 1 );
 198         return;
 199     }
 200     $rpm_locked = $name;
 201
 202     # preparing command
 203     my $cmd  = "sudo urpmi --auto 'perl($name)'";
 204     $self->_log_new_step('Installing from upstream', "Running command: $cmd" );
 205
 206     # running command
 207     $self->_output('');
 208     $ENV{LC_ALL} = 'C';
 209     my $wheel = POE::Wheel::Run->new(
 210         Program      => $cmd,
 211         StdoutEvent  => '_stdout',
 212         StderrEvent  => '_stderr',
 213         Conduit      => 'pty-pipe', # urpmi wants a pty
 214         StdoutFilter => POE::Filter::Line->new,
 215         StderrFilter => POE::Filter::Line->new,
 216     );
 217     $k->sig( CHLD => '_install_from_dist' );
 218
 219     # need to store the wheel, otherwise the process goes woo!
 220     $self->_wheel($wheel);
 221 }
 222
 223 sub install_from_local {
 224     my ($k, $self) = @_[KERNEL, OBJECT];
 225     my $name = $self->name;
 226
 227     # check whether there's another rpm transaction
 228     if ( $rpm_locked ) {
 229         $self->_log_prefixed_lines("waiting for rpm lock... (owned by $rpm_locked)");
 230         $k->delay( install_from_local => 1 );
 231         return;
 232     }
 233     $rpm_locked = $name;
 234
 235     # preparing command
 236     my $rpm = $self->_rpm;
 237     my $cmd = "sudo rpm -Uv $rpm";
 238     $self->_log_new_step('Installing from local', "Running command: $cmd" );
 239
 240     # running command
 241     $self->_output('');
 242     $ENV{LC_ALL} = 'C';
 243     my $wheel = POE::Wheel::Run->new(
 244         Program      => $cmd,
 245         StdoutEvent  => '_stdout',
 246         StderrEvent  => '_stderr',
 247         StdoutFilter => POE::Filter::Line->new,
 248         StderrFilter => POE::Filter::Line->new,
 249     );
 250     $k->sig( CHLD => '_install_from_local' );
 251
 252     # need to store the wheel, otherwise the process goes woo!
 253     $self->_wheel($wheel);
 254 }
 255
 256 sub is_in_dist {
 257     my ($k, $self) = @_[KERNEL, OBJECT];
 258
 259     # preparing command
 260     my $name = $self->name;
 261     my $cmd  = "urpmq --whatprovides 'perl($name)'";
 262     $self->_log_new_step('Checking if packaged upstream', "Running command: $cmd" );
 263
 264     # running command
 265     $self->_output('');
 266     $ENV{LC_ALL} = 'C';
 267     my $wheel = POE::Wheel::Run->new(
 268         Program      => $cmd,
 269         #CloseEvent   => '_is_in_dist', # FIXME: cf rt#42757
 270         StdoutEvent  => '_stdout',
 271         StderrEvent  => '_stderr',
 272         Conduit      => 'pty-pipe', # urpmq wants a pty
 273         StdoutFilter => POE::Filter::Line->new,
 274         StderrFilter => POE::Filter::Line->new,
 275     );
 276     $k->sig( CHLD => '_is_in_dist' );
 277
 278     # need to store the wheel, otherwise the process goes woo!
 279     $self->_wheel($wheel);
 280 }
 281
 282
 283 sub is_installed {
 284     my ($k, $self) = @_[KERNEL, OBJECT];
 285
 286     my $name = $self->name;
 287     my $cmd  = qq{ require $name };
 288     $self->_log_new_step(
 289         'Checking if module is installed',
 290         "Evaluating command: $cmd"
 291     );
 292
 293     eval $cmd;
 294     my $what = $@ || "$name loaded successfully\n";
 295     $k->post('ui', 'append', $self, $what);
 296
 297     my $is_installed = $@ eq '';
 298     my $status = $is_installed ? 'installed' : 'not installed';
 299     $self->_log_result("$name is $status locally.");
 300     $k->post('app', 'local_status', $self, $is_installed);
 301 }
 302
 303 # -- private events
 304
 305 sub _build_upstream {
 306     my($k, $self, $pid, $rv) = @_[KERNEL, OBJECT, ARG1, ARG2];
 307
 308     # since it's a sigchld handler, it also gets called for other
 309     # spawned processes. therefore, screen out processes that are
 310     # not related to this object.
 311     return unless defined $self->_wheel;
 312     return unless $self->_wheel->PID == $pid;
 313
 314     # terminate wheel
 315     $self->_wheel(undef);
 316
 317     # we don't have a real way to know when the build is finished,
 318     # and when the package is available upstream. therefore, we're going
 319     # to ask the user to signal when it's available...
 320     my $name = $self->name;
 321     $self->_log_result( "$name has been submitted upstream." );
 322     my $question = "type 'enter' when package is available on build system upstream";
 323     $k->post('ui', 'ask_user', $self, $question, 'available_on_bs');
 324 }
 325
 326
 327 sub _cpan2dist {
 328     my ($k, $self, $id) = @_[KERNEL, OBJECT, ARG0];
 329     my $name = $self->name;
 330
 331     # terminate wheel
 332     my $wheel  = $self->_wheel;
 333     $self->_wheel(undef);
 334
 335     # check whether the package has been built correctly.
 336     my $output = $self->_output;
 337     my ($rpm, $srpm);
 338     $rpm  = $1 if $output =~ /rpm created successfully: (.*\.rpm)/;
 339     $srpm = $1 if $output =~ /srpm available: (.*\.src.rpm)/;
 340
 341     my ($status, @result);
 342     if ( $rpm && $srpm ) {
 343         $status = 1;
 344         @result = (
 345             "$name has been successfully built",
 346             "srpm created: $srpm",
 347             "rpm created:  $rpm",
 348         );
 349
 350         # storing path to interesting files
 351         $self->_rpm($rpm);
 352         $self->_srpm($srpm);
 353
 354         # storing package name
 355         my $pkgname = basename $srpm;
 356         $pkgname =~ s/-\d.*$//;
 357         $self->_pkgname( $pkgname );
 358
 359     } else {
 360         $status = 0;
 361         @result = ( "error while building $name" );
 362     }
 363
 364     # update main application
 365     $self->_log_result(@result);
 366     $k->post('app', 'cpan2dist_status', $self, $status);
 367 }
 368
 369 sub _import_upstream {
 370     my($k, $self, $pid, $rv) = @_[KERNEL, OBJECT, ARG1, ARG2];
 371
 372     # since it's a sigchld handler, it also gets called for other
 373     # spawned processes. therefore, screen out processes that are
 374     # not related to this object.
 375     return unless defined $self->_wheel;
 376     return unless $self->_wheel->PID == $pid;
 377
 378     # terminate wheel
 379     $self->_wheel(undef);
 380
 381     # log result
 382     my $name  = $self->name;
 383     my $exval = $rv >> 8;
 384     my $status = $exval ? 'not been' : 'been';
 385     $self->_log_result( "$name has $status imported upstream." );
 386     $k->post('app', 'upstream_import', $self, !$exval);
 387 }
 388
 389
 390 sub _find_prereqs {
 391     my ($k, $self, $id) = @_[KERNEL, OBJECT, ARG0];
 392
 393     # terminate wheel
 394     my $wheel  = $self->_wheel;
 395     $self->_wheel(undef);
 396
 397     # extract prereqs
 398     my @lines   = split /\n/, $self->_output;
 399     my @tabbed  = grep { s/^\s+// } @lines;
 400     my $idx     = firstidx { /^Module\s+Req Ver.*Satisfied/ } @tabbed;
 401     my @wanted  = @tabbed[ $idx+1 .. $#tabbed ];
 402     my @prereqs = map  { (split /\s+/, $_)[0] } @wanted;
 403
 404     # store prereqs
 405     $self->_prereqs( \@prereqs );
 406     my @logs = @prereqs
 407         ? map { "prereq found: $_" } @prereqs
 408         : 'No prereqs found.';
 409     $self->_log_result(@logs);
 410     $k->post('app', 'prereqs', $self, @prereqs);
 411 }
 412
 413 sub _install_from_dist {
 414     my($k, $self, $pid, $rv) = @_[KERNEL, OBJECT, ARG1, ARG2];
 415
 416     # since it's a sigchld handler, it also gets called for other
 417     # spawned processes. therefore, screen out processes that are
 418     # not related to this object.
 419     return unless defined $self->_wheel;
 420     return unless $self->_wheel->PID == $pid;
 421
 422     # terminate wheel
 423     $self->_wheel(undef);
 424
 425     # release rpm lock
 426     $rpm_locked = '';
 427
 428     # log result
 429     my $name  = $self->name;
 430     my $exval = $rv >> 8;
 431     my $status = $exval ? 'not been' : 'been';
 432     $self->_log_result( "$name has $status installed from upstream." );
 433     $k->post('app', 'upstream_install', $self, !$exval);
 434 }
 435
 436
 437 sub _install_from_local {
 438     my($k, $self, $pid, $rv) = @_[KERNEL, OBJECT, ARG1, ARG2];
 439
 440     # since it's a sigchld handler, it also gets called for other
 441     # spawned processes. therefore, screen out processes that are
 442     # not related to this object.
 443     return unless defined $self->_wheel;
 444     return unless $self->_wheel->PID == $pid;
 445
 446     # terminate wheel
 447     $self->_wheel(undef);
 448
 449     # release rpm lock
 450     $rpm_locked = '';
 451
 452     # log result
 453     my $name  = $self->name;
 454     my $rpm   = $self->_rpm;
 455     my $exval = $rv >> 8;
 456     my $status = $exval ? 'not been' : 'been';
 457     $self->_log_result( "$name has $status installed from $rpm." );
 458     $k->post('app', 'local_install', $self, !$exval);
 459 }
 460
 461
 462 sub _is_in_dist {
 463     my($k, $self, $pid, $rv) = @_[KERNEL, OBJECT, ARG1, ARG2];
 464
 465     # since it's a sigchld handler, it also gets called for other
 466     # spawned processes. therefore, screen out processes that are
 467     # not related to this object.
 468     return unless defined $self->_wheel;
 469     return unless $self->_wheel->PID == $pid;
 470
 471     # terminate wheel
 472     # FIXME: should be done in CloseEvent
 473     $self->_wheel(undef);
 474
 475     # check if we got a hit
 476     # urpmq returns 0 if found, 1 otherwise.
 477     my $name  = $self->name;
 478     my $exval = $rv >> 8;
 479
 480     my $status = $exval ? 'not' : 'already';
 481     $self->_log_result( "$name is $status packaged upstream." );
 482     $k->post('app', 'upstream_status', $self, !$exval);
 483 }
 484
 485 sub _stderr {
 486     my ($k, $self, $line) = @_[KERNEL, OBJECT, ARG0];
 487     $k->post('ui', 'append', $self, "stderr: $line\n");
 488 }
 489
 490 sub _stdout {
 491     my ($k, $self, $line) = @_[KERNEL, OBJECT, ARG0];
 492     $line .= "\n";
 493     $self->_output( $self->_output . $line );
 494     $k->post('ui', 'append', $self, "stdout: $line");
 495 }
 496
 497
 498 # -- poe inline states
 499
 500 sub _start {
 501     my ($k, $self) = @_[KERNEL, OBJECT];
 502
 503     $k->alias_set($self);
 504     $k->alias_set($self->name);
 505     $k->post('ui',  'module_spawned', $self);
 506     $k->post('app', 'module_spawned', $self);
 507 }
 508
 509
 510 #--
 511 # METHODS
 512
 513 # -- public methods
 514
 515 sub blocking_add {
 516     my ($self, $name) = @_;
 517     $self->_blocking->{$name} = 1;
 518 }
 519
 520 sub blocking_clear {
 521     my ($self, $name) = @_;
 522     $self->_blocking({});
 523 }
 524
 525 sub blocking_list {
 526     my ($self) = @_;
 527     my $blocking = $self->_blocking;
 528     return sort keys %$blocking;
 529 }
 530
 531 #
 532
 533 sub missing_add {
 534     my ($self, $name) = @_;
 535     warn "$self / $name";
 536     $self->_missing->{$name} = 1;
 537 }
 538
 539 sub missing_del {
 540     my ($self, $name) = @_;
 541     delete $self->_missing->{$name};
 542 }
 543
 544 sub missing_list {
 545     my ($self) = @_;
 546     my $missing = $self->_missing;
 547     return sort keys %$missing;
 548 }
 549
 550 # -- private methods
 551
 552 sub _log_empty_line {
 553     my ($self, $nb) = @_;
 554     $nb //= 1; #/ FIXME padre syntaxic color glitch
 555     POE::Kernel->post('ui', 'append', $self, "\n" x $nb);
 556 }
 557
 558 sub _log_prefixed_lines {
 559     my ($self, @lines) = @_;
 560
 561     my $prefix = '*';
 562     POE::Kernel->post('ui', 'append', $self, $_)
 563         for map { "$prefix $_\n" } @lines;
 564 }
 565
 566 sub _log_new_step {
 567     my ($self, $step, $comment) = @_;
 568
 569     $self->_log_prefixed_lines('-' x 10, $step, '', $comment, '');
 570     $self->_log_empty_line;
 571 }
 572
 573 sub _log_result {
 574     my ($self, @lines) = @_;
 575
 576     $self->_log_empty_line;
 577     $self->_log_prefixed_lines( '', @lines, '', '' );
 578 }
 579
 580
 581 1;
 582 __END__
 583
 584
 585 =head1 NAME
 586
 587 App::CPAN2Pkg::Module - poe session to drive a module packaging
 588
 589
 590
 591 =head1 DESCRIPTION
 592
 593 C<App::CPAN2Pkg::Module> implements a POE session driving the whole
 594 packaging process of a given module.
 595
 596 It is spawned by C<App::CPAN2Pkg> and implements the logic related to
 597 the module availability in the distribution.
 598
 599
 600
 601 =head1 METHODS
 602
 603 This package is also a class, used B<internally> to store private data
 604 needed for the packaging stuff.
 605
 606
 607
 608 =head2 Constructor
 609
 610 =over 4
 611
 612 =item my $module = App::CPAN2Pkg::Module->new(name=>$name)
 613
 614 =back
 615
 616
 617
 618 =head2 Accessors
 619
 620 The following accessors are available:
 621
 622 =over 4
 623
 624 =item is_local() - whether the module is installed locally
 625
 626 =item name() - the module name
 627
 628 =back
 629
 630
 631
 632 =head2 Public methods
 633
 634 =over 4
 635
 636 =item blocking_add( $module )
 637
 638 Add C<$module> to the list of modules that current object is blocking
 639 from locally before trying to build
 640 the object.
 641
 642
 643 =item blocking_clear( $module )
 644
 645 Remove C<$module> from the list of modules missing locally. This means that
 646 module has been built and installed by cpan2pkg.
 647
 648
 649 =item blocking_list( )
 650
 651 Get the list of modules missing before trying to build the object.
 652
 653
 654 =item missing_add( $module )
 655
 656 Add C<$module> to the list of modules missing locally before trying to build
 657 the object.
 658
 659
 660 =item missing_del( $module )
 661
 662 Remove C<$module> from the list of modules missing locally. This means that
 663 module has been built and installed by cpan2pkg.
 664
 665
 666 =item missing_list( )
 667
 668 Get the list of modules missing before trying to build the object.
 669
 670
 671 =back
 672
 673
 674
 675
 676 =head2 Public events accepted
 677
 678
 679 =over 4
 680
 681 =item available_on_bs()
 682
 683 Sent when module is available on upstream build system.
 684
 685
 686 =item build_upstream()
 687
 688 Submit package to be build on upstream build system.
 689
 690
 691 =item cpan2dist()
 692
 693 Build a native package for this module, using C<cpan2dist> with the C<--force> flag.
 694
 695
 696 =item find_prereqs()
 697
 698 Start looking for any other module needed by current module.
 699
 700
 701 =item import_upstream()
 702
 703 Try to import module into upstream distribution.
 704
 705
 706 =item install_from_dist()
 707
 708 Try to install module from upstream distribution.
 709
 710
 711 =item install_from_local()
 712
 713 Try to install module from package freshly build.
 714
 715
 716 =item is_in_dist()
 717
 718 Check whether the package is provided by an existing upstream package.
 719
 720
 721 =item is_installed()
 722
 723 Check whether the package is installed locally.
 724
 725
 726 =back
 727
 728
 729
 730 =head1 SEE ALSO
 731
 732 For all related information (bug reporting, source code repository,
 733 etc.), refer to C<App::CPAN2Pkg>'s pod, section C<SEE ALSO>.
 734
 735
 736
 737 =head1 AUTHOR
 738
 739 Jerome Quelin, C<< <jquelin@cpan.org> >>
 740
 741
 742
 743 =head1 COPYRIGHT & LICENSE
 744
 745 Copyright (c) 2009 Jerome Quelin, all rights reserved.
 746
 747 This program is free software; you can redistribute it and/or modify
 748 it under the same terms as Perl itself.
 749
 750 =cut
 751