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