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