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