lib/Parrot/Configure.pm

   1 # Copyright (C) 2001-2009, Parrot Foundation.
   2 # $Id$
   3
   4 package Parrot::Configure;
   5
   6 use strict;
   7 use warnings;
   8
   9 =head1 NAME
  10
  11 Parrot::Configure - Conducts the execution of Configuration Steps
  12
  13 =head1 SYNOPSIS
  14
  15     use Parrot::Configure;
  16
  17     my $conf    = Parrot::Configure->new;
  18     my $data    = $conf->data;
  19     my $options = $conf->options;
  20     my @steps   = $conf->steps;
  21
  22     $conf->add_steps(@steps);
  23     $conf->runsteps;
  24     $conf->debug(@messages);
  25
  26 =head1 DESCRIPTION
  27
  28 This module provides a means for registering, executing, and
  29 coordinating one or more configuration steps.  Please see
  30 F<docs/configuration.pod> for further details about the configuration
  31 framework.
  32
  33 =head1 USAGE
  34
  35 =head2 Import Parameters
  36
  37 This module accepts no arguments to its C<import> method and exports no
  38 I<symbols>.
  39
  40 =cut
  41
  42 use lib qw(config);
  43 use Carp qw(carp);
  44 use Storable qw(2.12 nstore retrieve nfreeze thaw);
  45 use Parrot::Configure::Data;
  46 use base qw(Parrot::Configure::Compiler);
  47
  48 use Class::Struct;
  49
  50 struct(
  51     'Parrot::Configure::Task' => {
  52         step   => '$',
  53         object => 'Parrot::Configure::Step',
  54     },
  55 );
  56
  57 =head2 Methods
  58
  59 =head3 Constructor
  60
  61 =over 4
  62
  63 =item * C<new()>
  64
  65 Basic constructor.
  66
  67 Accepts no arguments and returns a Parrot::Configure object.
  68
  69 =cut
  70
  71 my $singleton;
  72
  73 BEGIN {
  74     $singleton = {
  75         steps   => [],
  76         data    => Parrot::Configure::Data->new,
  77         options => Parrot::Configure::Data->new,
  78     };
  79     bless $singleton, 'Parrot::Configure';
  80 }
  81
  82 sub new {
  83     my $class = shift;
  84     return $singleton;
  85 }
  86
  87 =back
  88
  89 =head3 Object Methods
  90
  91 =over 4
  92
  93 =item * C<data()>
  94
  95 Provides access to a Parrot::Configure::Data object intended to contain
  96 initial and discovered configuration data.
  97
  98 Accepts no arguments and returns a Parrot::Configure::Data object.
  99
 100 =cut
 101
 102 sub data {
 103     my $conf = shift;
 104
 105     return $conf->{data};
 106 }
 107
 108 =item * C<options()>
 109
 110 Provides access to a Parrot::Configure::Data object intended to contain CLI
 111 option data.
 112
 113 Accepts no arguments and returns a Parrot::Configure::Data object.
 114
 115 =cut
 116
 117 sub options {
 118     my $conf = shift;
 119
 120     return $conf->{options};
 121 }
 122
 123 =item * C<steps()>
 124
 125 Provides a list of registered steps, where each step is represented by an
 126 Parrot::Configure::Task object.  Steps are returned in the order in which
 127 they were registered.
 128
 129 Accepts no arguments and returns a list in list context or an arrayref in
 130 scalar context.
 131
 132 =cut
 133
 134 sub steps {
 135     my $conf = shift;
 136
 137     return wantarray ? @{ $conf->{steps} } : $conf->{steps};
 138 }
 139
 140 =item * C<get_list_of_steps()>
 141
 142 Provides a list of the B<names> of registered steps.
 143
 144 C<steps()>, in contrast, provides a list of registered step B<objects>, of
 145 which the B<step name> is just a small part.  Step names are returned in the
 146 order in which their corresponding step objects were registered.
 147
 148 Accepts no arguments and returns a list in list context or an arrayref in
 149 scalar context.
 150
 151 B<Note:> The list of step names returned by C<get_list_of_steps()> will be the
 152 same as that in the second argument returned by
 153 C<Parrot::Configure::Options::process_options()> B<provided> that you have not
 154 used C<add_step()> or C<add_steps()> to add any configuration steps.
 155
 156 =cut
 157
 158 sub get_list_of_steps {
 159     my $conf = shift;
 160     die 'list_of_steps not available until steps have been added'
 161         unless defined $conf->{list_of_steps};
 162     return wantarray ? @{ $conf->{list_of_steps} } : $conf->{list_of_steps};
 163 }
 164
 165 =item * C<add_step()>
 166
 167 Registers a new step and any parameters that should be passed to it.  The
 168 first parameter passed is the class name of the step being registered.  All
 169 other parameters are saved and passed to the registered class's C<runstep()>
 170 method.
 171
 172 Accepts a list and modifies the data structure within the
 173 Parrot::Configure object.
 174
 175 =cut
 176
 177 sub add_step {
 178     my ( $conf, $step ) = @_;
 179
 180     push @{ $conf->{steps} },
 181         Parrot::Configure::Task->new(
 182             step   => $step,
 183         );
 184
 185     return 1;
 186 }
 187
 188 =item * C<add_steps()>
 189
 190 Registers new steps to be run at the end of the execution queue.
 191
 192 Accepts a list of new steps and modifies the data structure within the
 193 Parrot::Configure object.
 194
 195 =cut
 196
 197 sub add_steps {
 198     my ( $conf, @new_steps ) = @_;
 199
 200     for ( my $i = 0 ; $i <= $#new_steps ; $i++ ) {
 201         $conf->add_step( $new_steps[$i] );
 202         push @{ $conf->{list_of_steps} }, $new_steps[$i];
 203         $conf->{hash_of_steps}->{ $new_steps[$i] } = $i + 1;
 204     }
 205
 206     return 1;
 207 }
 208
 209 =item * C<runsteps()>
 210
 211 Sequentially executes steps in the order they were registered.  The invoking
 212 Parrot::Configure object is passed as the first argument to each step's
 213 C<runstep()> method, followed by any parameters that were registered for that
 214 step.
 215
 216 Accepts no arguments and modifies the data structure within the
 217 Parrot::Configure object.
 218
 219 =cut
 220
 221 sub runsteps {
 222     my $conf = shift;
 223
 224     my $n = 0;    # step number
 225     my ( $silent, $verbose, $verbose_step_str, $fatal, $fatal_step_str, $ask );
 226     $silent = $conf->options->get(qw( silent ));
 227     unless ($silent) {
 228         ( $verbose, $verbose_step_str, $fatal, $fatal_step_str, $ask ) =
 229             $conf->options->get(qw( verbose verbose-step fatal fatal-step ask ));
 230     }
 231
 232     $conf->{log} = [];
 233     my %steps_to_die_for = ();
 234     # If the --fatal option is true, then all config steps are mapped into
 235     # %steps_to_die_for and there is no consideration of --fatal-step.
 236     if ($fatal) {
 237         %steps_to_die_for = map { ($_,1) } @{ $conf->{list_of_steps} };
 238     }
 239     # We make certain that argument to --fatal-step is a comma-delimited
 240     # string of configuration steps, each of which is a string delimited by
 241     # two colons, the first half of which is one of init|inter|auto|gen
 242     elsif ( defined ( $fatal_step_str ) ) {
 243         %steps_to_die_for = _handle_fatal_step_option( $fatal_step_str );
 244     }
 245     else {
 246         # No action needed; this is the default case where no step is fatal
 247     }
 248
 249     my %verbose_steps;
 250     if (defined $verbose_step_str) {
 251         %verbose_steps = _handle_verbose_step_option( $verbose_step_str );
 252     }
 253     foreach my $task ( $conf->steps ) {
 254         my ($red_flag, $this_step_is_verbose);
 255         my $step_name   = $task->step;
 256         if ( scalar keys %steps_to_die_for ) {
 257             if ( $steps_to_die_for{$step_name} ) {
 258                 $red_flag++;
 259             }
 260         }
 261         if ( scalar keys %verbose_steps ) {
 262              $this_step_is_verbose = $verbose_steps{$step_name}
 263                 ? $step_name
 264                 : q{};
 265         }
 266
 267         $n++;
 268         my $rv = $conf->_run_this_step(
 269             {
 270                 task            => $task,
 271                 verbose         => $verbose,
 272                 verbose_step    => $this_step_is_verbose,
 273                 ask             => $ask,
 274                 n               => $n,
 275                 silent          => $silent,
 276             }
 277         );
 278         if ( ! defined $rv ) {
 279             if ( $red_flag ) {
 280                 return;
 281             }
 282             else {
 283                 $conf->{log}->[$n] = {
 284                     step    => $step_name,
 285                 };
 286             }
 287         }
 288     }
 289     return 1;
 290 }
 291
 292 sub _handle_fatal_step_option {
 293     my $fatal_step_str = shift;
 294     my %steps_to_die_for = ();
 295     my $named_step_pattern = qr/(?:init|inter|auto|gen)::\w+/;
 296     if ( $fatal_step_str =~ m{^
 297         $named_step_pattern
 298         (, $named_step_pattern)*
 299         $}x
 300     ) {
 301         my @fatal_steps = split /,/, $fatal_step_str;
 302         for my $s (@fatal_steps) {
 303             $steps_to_die_for{$s}++;
 304         }
 305     }
 306     else {
 307         die q{Argument to fatal-step option must be comma-delimited string of valid configuration steps};
 308     }
 309     return %steps_to_die_for;
 310 }
 311
 312 sub _handle_verbose_step_option {
 313     my $verbose_step_str = shift;
 314     my %verbose_steps = ();
 315     my $named_step_pattern = qr/(?:init|inter|auto|gen)::\w+/;
 316     if ( $verbose_step_str =~ m{^
 317         $named_step_pattern
 318         (, $named_step_pattern)*
 319         $}x
 320     ) {
 321         my @verbose_steps = split /,/, $verbose_step_str;
 322         for my $s (@verbose_steps) {
 323             $verbose_steps{$s}++;
 324         }
 325     }
 326     else {
 327         die q{Argument to verbose-step option must be comma-delimited string of valid configuration steps};
 328     }
 329     return %verbose_steps;
 330 }
 331
 332 =item * C<run_single_step()>
 333
 334 The invoking Parrot::Configure object is passed as the first argument to
 335 each step's C<runstep()> method, followed by any parameters that were
 336 registered for that step.
 337
 338 Accepts no arguments and modifies the data structure within the
 339 Parrot::Configure object.
 340
 341 B<Note:>  Currently used only in F<tools/dev/reconfigure.pl>; not used in
 342 F<Configure.pl>.
 343
 344 =cut
 345
 346 sub run_single_step {
 347     my $conf     = shift;
 348     my $taskname = shift;
 349
 350     my ( $verbose, $verbose_step, $ask ) =
 351         $conf->options->get(qw( verbose verbose-step ask ));
 352
 353     my $task = ( $conf->steps() )[0];
 354     if ( $task->{'Parrot::Configure::Task::step'} eq $taskname ) {
 355         $conf->_run_this_step(
 356             {
 357                 task            => $task,
 358                 verbose         => $verbose,
 359                 verbose_step    => $verbose_step,
 360                 ask             => $ask,
 361                 n               => 1,
 362             }
 363         );
 364     }
 365     else {
 366         die 'Mangled task in run_single_step';
 367     }
 368
 369     return;
 370 }
 371
 372 sub _run_this_step {
 373     my $conf = shift;
 374     my $args = shift;
 375
 376     my $step_name   = $args->{task}->step;
 377
 378     eval "use $step_name;"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
 379     die $@ if $@;
 380
 381     my $conftrace = [];
 382     my $sto       = q{.configure_trace.sto};
 383     {
 384         local $Storable::Eval = 1;
 385         if ( $conf->options->get(q{configure_trace}) and ( -e $sto ) ) {
 386             $conftrace = retrieve($sto);
 387         }
 388     }
 389     my $step = $step_name->new();
 390
 391     # set per step verbosity
 392     if ( $args->{verbose_step} ) {
 393         $conf->options->set( verbose => 2 );
 394     }
 395
 396     my $stub = qq{$step_name - };
 397     my $message = $stub .
 398         (q{ } x (22 - length($stub))) .
 399         $step->description .
 400         '...';
 401     my $length_message = length($message);
 402     unless ($args->{silent}) {
 403         # The first newline terminates the report on the *previous* step.
 404         # (Probably needed to make interactive output work properly.
 405         # Otherwise, we'd put it in _finish_printing_result().
 406         print "\n";
 407         print $message;
 408         print "\n" if $args->{verbose_step};
 409     }
 410
 411     my $ret;
 412     # When successful, a Parrot configuration step now returns 1
 413     eval { $ret = $step->runstep($conf); };
 414     if ($@) {
 415         carp "\nstep $step_name died during execution: $@\n";
 416         return;
 417     }
 418     else {
 419         # A Parrot configuration step can run successfully, but if it fails to
 420         # achieve its objective it is supposed to return an undefined status.
 421         if ( $ret ) {
 422             # reset verbose value for the next step
 423             $conf->options->set( verbose => $args->{verbose} );
 424             unless ($args->{silent}) {
 425                 _finish_printing_result(
 426                     {
 427                         step        => $step,
 428                         step_name   => $step_name,
 429                         args        => $args,
 430                         description => $step->description,
 431                         length_message => $length_message,
 432                     }
 433                 );
 434             }
 435             if ($conf->options->get(q{configure_trace}) ) {
 436                 _update_conftrace(
 437                     {
 438                         conftrace   => $conftrace,
 439                         step_name   => $step_name,
 440                         conf        => $conf,
 441                         sto         => $sto,
 442                     }
 443                 );
 444             }
 445             return 1;
 446         }
 447         else {
 448             _failure_message( $step, $step_name );
 449             return;
 450         }
 451     }
 452 }
 453
 454 sub _failure_message {
 455     my ( $step, $step_name ) = @_;
 456     my $result = $step->result || 'no result returned';
 457     carp "\nstep $step_name failed: " . $result;
 458
 459     return;
 460 }
 461
 462
 463 sub _finish_printing_result {
 464     my $argsref = shift;
 465     my $result = $argsref->{step}->result || 'done';
 466     my $linelength = 78;
 467     if ($argsref->{args}->{verbose} or $argsref->{args}->{verbose_step}) {
 468         # For more readable verbose output, we'll repeat the step description
 469         print "\n";
 470         my $spaces = 22;
 471         print q{ } x $spaces;
 472         print $argsref->{description};
 473         print '.' x (
 474             ( $linelength - $spaces ) -
 475             ( length($argsref->{description}) + length($result) + 1 )
 476         );
 477     }
 478     else {
 479         print '.' x (
 480             $linelength -
 481             ( $argsref->{length_message} + length($result) + 1 )
 482         );
 483     }
 484     unless ( $argsref->{step_name} =~ m{^inter} && $argsref->{args}->{ask} ) {
 485         print "$result.";
 486     }
 487     return 1;
 488 }
 489
 490 sub _update_conftrace {
 491     my $argsref = shift;
 492     if (! defined $argsref->{conftrace}->[0]) {
 493         $argsref->{conftrace}->[0] = [];
 494     }
 495     push @{ $argsref->{conftrace}->[0] }, $argsref->{step_name};
 496     my $evolved_data = {
 497         options => $argsref->{conf}->{options},
 498         data    => $argsref->{conf}->{data},
 499     };
 500     push @{ $argsref->{conftrace} }, $evolved_data;
 501     {
 502         local $Storable::Deparse = 1;
 503         nstore( $argsref->{conftrace}, $argsref->{sto} );
 504     }
 505     return 1;
 506 }
 507
 508 =item * C<option_or_data($arg)>
 509
 510 Are you tired of this construction all over the place?
 511
 512     my $opt = $conf->options->get( $arg );
 513        $opt = $conf->data->get( $arg ) unless defined $opt;
 514
 515 It gives you the user-specified option for I<$arg>, and if there
 516 isn't one, it gets it from the created data.  You do it all the
 517 time, but oh! the wear and tear on your fingers!
 518
 519 Toil no more!  Use this simple construction:
 520
 521     my $opt = $conf->option_or_data($arg);
 522
 523 and save your fingers for some real work!
 524
 525 =cut
 526
 527 sub option_or_data {
 528     my $conf = shift;
 529     my $arg  = shift;
 530
 531     my $opt = $conf->options->get($arg);
 532     return defined $opt ? $opt : $conf->data->get($arg);
 533 }
 534
 535 sub pcfreeze {
 536     my $conf = shift;
 537     local $Storable::Deparse = 1;
 538     local $Storable::Eval = 1;
 539     return nfreeze($conf);
 540 }
 541
 542 sub replenish {
 543     my $conf = shift;
 544     my $serialized = shift;
 545     foreach my $k (keys %{$conf}) {
 546         delete $conf->{$k};
 547     }
 548     local $Storable::Deparse = 1;
 549     local $Storable::Eval = 1;
 550     my %gut = %{ thaw($serialized) };
 551     while ( my ($k, $v) = each %gut ) {
 552         $conf->{$k} = $v;
 553     }
 554
 555     return;
 556 }
 557
 558 =item * C<debug()>
 559
 560 When C<--verbose> is requested, or when a particular configuration step is
 561 specified in C<--verbose-step>, this method prints its arguments as a string
 562 on STDOUT.
 563
 564 =cut
 565
 566 sub debug {
 567     my ($conf, @messages) = @_;
 568     if ($conf->options->get('verbose')) {
 569         print join('' => @messages);
 570     }
 571     return 1;
 572 }
 573
 574 =back
 575
 576 =head1 CREDITS
 577
 578 The L</runsteps()> method is largely based on code written by Brent
 579 Royal-Gordon C<brent@brentdax.com>.
 580
 581 =head1 AUTHOR
 582
 583 Joshua Hoblitt C<jhoblitt@cpan.org>
 584
 585 =head1 SEE ALSO
 586
 587 F<docs/configuration.pod>, L<Parrot::Configure::Data>,
 588 L<Parrot::Configure::Utils>, L<Parrot::Configure::Step>
 589
 590 =cut
 591
 592 1;
 593
 594 # Local Variables:
 595 #   mode: cperl
 596 #   cperl-indent-level: 4
 597 #   fill-column: 100
 598 # End:
 599 # vim: expandtab shiftwidth=4: