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