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