File Coverage

File:lib/Parrot/Configure.pm
Coverage:85.2%

linestmtbrancondsubcode
1# Copyright (C) 2001-2009, Parrot Foundation.
2
3package Parrot::Configure;
4
5
106
106
106
106
use strict;
6
100
100
100
100
use warnings;
7
8 - 39
=head1 NAME

Parrot::Configure - Conducts the execution of Configuration Steps

=head1 SYNOPSIS

    use Parrot::Configure;

    my $conf    = Parrot::Configure->new;
    my $data    = $conf->data;
    my $options = $conf->options;
    my @steps   = $conf->steps;

    $conf->add_steps(@steps);
    $conf->runsteps;
    $conf->debug(@messages);

=head1 DESCRIPTION

This module provides a means for registering, executing, and
coordinating one or more configuration steps.  Please see
F<docs/configuration.pod> for further details about the configuration
framework.

=head1 USAGE

=head2 Import Parameters

This module accepts no arguments to its C<import> method and exports no
I<symbols>.

=cut
40
41
100
100
100
100
use lib qw(config);
42
100
100
100
100
use Carp qw(carp);
43
100
100
100
100
use Storable qw(2.12 nstore retrieve nfreeze thaw);
44
100
100
100
100
use Parrot::Configure::Data;
45
100
100
100
100
use base qw(Parrot::Configure::Compiler);
46
47
100
100
100
100
use Class::Struct;
48
49struct(
50    'Parrot::Configure::Task' => {
51        step => '$',
52        object => 'Parrot::Configure::Step',
53    },
54);
55
56 - 68
=head2 Methods

=head3 Constructor

=over 4

=item * C<new()>

Basic constructor.

Accepts no arguments and returns a Parrot::Configure object.

=cut
69
70my $singleton;
71
72BEGIN {
73
100
100
    $singleton = {
74        steps => [],
75        data => Parrot::Configure::Data->new,
76        options => Parrot::Configure::Data->new,
77    };
78
100
    bless $singleton, 'Parrot::Configure';
79}
80
81sub new {
82
38
38
    my $class = shift;
83
38
    return $singleton;
84}
85
86=back
87
88 - 99
=head3 Object Methods

=over 4

=item * C<data()>

Provides access to a Parrot::Configure::Data object intended to contain
initial and discovered configuration data.

Accepts no arguments and returns a Parrot::Configure::Data object.

=cut
100
101sub data {
102
28539
28539
    my $conf = shift;
103
104
28539
    return $conf->{data};
105}
106
107 - 114
=item * C<options()>

Provides access to a Parrot::Configure::Data object intended to contain CLI
option data.

Accepts no arguments and returns a Parrot::Configure::Data object.

=cut
115
116sub options {
117
2627
2627
    my $conf = shift;
118
119
2627
    return $conf->{options};
120}
121
122 - 131
=item * C<steps()>

Provides a list of registered steps, where each step is represented by an
Parrot::Configure::Task object.  Steps are returned in the order in which
they were registered.

Accepts no arguments and returns a list in list context or an arrayref in
scalar context.

=cut
132
133sub steps {
134
249
249
    my $conf = shift;
135
136
249
28
100
    return wantarray ? @{ $conf->{steps} } : $conf->{steps};
137}
138
139 - 155
=item * C<get_list_of_steps()>

Provides a list of the B<names> of registered steps.

C<steps()>, in contrast, provides a list of registered step B<objects>, of
which the B<step name> is just a small part.  Step names are returned in the
order in which their corresponding step objects were registered.

Accepts no arguments and returns a list in list context or an arrayref in
scalar context.

B<Note:> The list of step names returned by C<get_list_of_steps()> will be the
same as that in the second argument returned by
C<Parrot::Configure::Options::process_options()> B<provided> that you have not
used C<add_step()> or C<add_steps()> to add any configuration steps.

=cut
156
157sub get_list_of_steps {
158
20
20
    my $conf = shift;
159
20
100
    die 'list_of_steps not available until steps have been added'
160        unless defined $conf->{list_of_steps};
161
18
17
100
    return wantarray ? @{ $conf->{list_of_steps} } : $conf->{list_of_steps};
162}
163
164 - 174
=item * C<add_step()>

Registers a new step and any parameters that should be passed to it.  The
first parameter passed is the class name of the step being registered.  All
other parameters are saved and passed to the registered class's C<runstep()>
method.

Accepts a list and modifies the data structure within the
Parrot::Configure object.

=cut
175
176sub add_step {
177
520
520
    my ( $conf, $step ) = @_;
178
179
520
520
    push @{ $conf->{steps} },
180        Parrot::Configure::Task->new(
181            step => $step,
182        );
183
184
520
    return 1;
185}
186
187 - 194
=item * C<add_steps()>

Registers new steps to be run at the end of the execution queue.

Accepts a list of new steps and modifies the data structure within the
Parrot::Configure object.

=cut
195
196sub add_steps {
197
153
153
    my ( $conf, @new_steps ) = @_;
198
199
153
    for ( my $i = 0 ; $i <= $#new_steps ; $i++ ) {
200
515
        $conf->add_step( $new_steps[$i] );
201
515
515
        push @{ $conf->{list_of_steps} }, $new_steps[$i];
202
515
        $conf->{hash_of_steps}->{ $new_steps[$i] } = $i + 1;
203    }
204
205
153
    return 1;
206}
207
208 - 218
=item * C<runsteps()>

Sequentially executes steps in the order they were registered.  The invoking
Parrot::Configure object is passed as the first argument to each step's
C<runstep()> method, followed by any parameters that were registered for that
step.

Accepts no arguments and modifies the data structure within the
Parrot::Configure object.

=cut
219
220sub runsteps {
221
25
25
    my $conf = shift;
222
223
25
    my $n = 0; # step number
224
25
    my ( $silent, $verbose, $verbose_step_str, $fatal, $fatal_step_str, $ask );
225
25
    $silent = $conf->options->get(qw( silent ));
226
25
100
    unless ($silent) {
227
23
        ( $verbose, $verbose_step_str, $fatal, $fatal_step_str, $ask ) =
228            $conf->options->get(qw( verbose verbose-step fatal fatal-step ask ));
229    }
230
231
25
    $conf->{log} = [];
232
25
    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
25
100
100
    if ($fatal) {
236
2
63
2
        %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
5
        %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
24
    my %verbose_steps;
249
24
100
    if (defined $verbose_step_str) {
250
4
        %verbose_steps = _handle_verbose_step_option( $verbose_step_str );
251    }
252
23
    foreach my $task ( $conf->steps ) {
253
83
        my ($red_flag, $this_step_is_verbose);
254
83
        my $step_name = $task->step;
255
83
100
        if ( scalar keys %steps_to_die_for ) {
256
5
100
            if ( $steps_to_die_for{$step_name} ) {
257
4
                $red_flag++;
258            }
259        }
260
83
100
        if ( scalar keys %verbose_steps ) {
261
3
50
             $this_step_is_verbose = $verbose_steps{$step_name}
262                ? $step_name
263                : q{};
264        }
265
266
83
        $n++;
267
83
        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
82
100
        if ( ! defined $rv ) {
278
9
100
            if ( $red_flag ) {
279
4
                return;
280            }
281            else {
282
6
                $conf->{log}->[$n] = {
283                    step => $step_name,
284                };
285            }
286        }
287    }
288
19
    return 1;
289}
290
291sub _handle_fatal_step_option {
292
5
5
    my $fatal_step_str = shift;
293
5
    my %steps_to_die_for = ();
294
5
    my $named_step_pattern = qr/(?:init|inter|auto|gen)::\w+/;
295
5
100
    if ( $fatal_step_str =~ m{^
296        $named_step_pattern
297        (, $named_step_pattern)*
298        $}x
299    ) {
300
4
        my @fatal_steps = split /,/, $fatal_step_str;
301
4
        for my $s (@fatal_steps) {
302
5
            $steps_to_die_for{$s}++;
303        }
304    }
305    else {
306
2
        die q{Argument to fatal-step option must be comma-delimited string of valid configuration steps};
307    }
308
4
    return %steps_to_die_for;
309}
310
311sub _handle_verbose_step_option {
312
4
4
    my $verbose_step_str = shift;
313
4
    my %verbose_steps = ();
314
4
    my $named_step_pattern = qr/(?:init|inter|auto|gen)::\w+/;
315
4
100
    if ( $verbose_step_str =~ m{^
316        $named_step_pattern
317        (, $named_step_pattern)*
318        $}x
319    ) {
320
3
        my @verbose_steps = split /,/, $verbose_step_str;
321
3
        for my $s (@verbose_steps) {
322
3
            $verbose_steps{$s}++;
323        }
324    }
325    else {
326
2
        die q{Argument to verbose-step option must be comma-delimited string of valid configuration steps};
327    }
328
3
    return %verbose_steps;
329}
330
331 - 343
=item * C<run_single_step()>

The invoking Parrot::Configure object is passed as the first argument to
each step's C<runstep()> method, followed by any parameters that were
registered for that step.

Accepts no arguments and modifies the data structure within the
Parrot::Configure object.

B<Note:>  Currently used only in F<tools/dev/reconfigure.pl>; not used in
F<Configure.pl>.

=cut
344
345sub run_single_step {
346
6
6
    my $conf = shift;
347
6
    my $taskname = shift;
348
349
6
    my ( $verbose, $verbose_step, $ask ) =
350        $conf->options->get(qw( verbose verbose-step ask ));
351
352
6
    my $task = ( $conf->steps() )[0];
353
6
100
    if ( $task->{'Parrot::Configure::Task::step'} eq $taskname ) {
354
5
        $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
2
        die 'Mangled task in run_single_step';
366    }
367
368
4
    return;
369}
370
371sub _run_this_step {
372
87
109
    my $conf = shift;
373
87
    my $args = shift;
374
375
87
    my $step_name = $args->{task}->step;
376
377
87
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
22
20
20
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
    eval "use $step_name;"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
378
87
100
    die $@ if $@;
379
380
85
    my $conftrace = [];
381
85
    my $sto = q{.configure_trace.sto};
382    {
383
85
85
        local $Storable::Eval = 1;
384
85
100
100
        if ( $conf->options->get(q{configure_trace}) and ( -e $sto ) ) {
385
61
            $conftrace = retrieve($sto);
386        }
387    }
388
85
    my $step = $step_name->new();
389
390    # set per step verbosity
391
85
100
    if ( $args->{verbose_step} ) {
392
3
        $conf->options->set( verbose => 2 );
393    }
394
395
85
    my $stub = qq{$step_name - };
396
85
    my $message = $stub .
397        (q{ } x (22 - length($stub))) .
398        $step->description .
399        '...';
400
85
    my $length_message = length($message);
401
85
100
    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
83
        print "\n";
406
83
        print $message;
407
83
100
        print "\n" if $args->{verbose_step};
408    }
409
410
85
    my $ret;
411    # When successful, a Parrot configuration step now returns 1
412
85
85
    eval { $ret = $step->runstep($conf); };
413
85
100
    if ($@) {
414
4
        carp "\nstep $step_name died during execution: $@\n";
415
4
        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
82
100
        if ( $ret ) {
421            # reset verbose value for the next step
422
76
            $conf->options->set( verbose => $args->{verbose} );
423
76
100
            unless ($args->{silent}) {
424
75
                _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
76
100
            if ($conf->options->get(q{configure_trace}) ) {
435
62
                _update_conftrace(
436                    {
437                        conftrace => $conftrace,
438                        step_name => $step_name,
439                        conf => $conf,
440                        sto => $sto,
441                    }
442                );
443            }
444
76
            return 1;
445        }
446        else {
447
7
            _failure_message( $step, $step_name );
448
7
            return;
449        }
450    }
451}
452
453sub _failure_message {
454
7
7
    my ( $step, $step_name ) = @_;
455
7
100
    my $result = $step->result || 'no result returned';
456
7
    carp "\nstep $step_name failed: " . $result;
457
458
7
    return;
459}
460
461
462sub _finish_printing_result {
463
75
75
    my $argsref = shift;
464
75
100
    my $result = $argsref->{step}->result || 'done';
465
75
    my $linelength = 78;
466
75
100
100
    if ($argsref->{args}->{verbose} or $argsref->{args}->{verbose_step}) {
467        # For more readable verbose output, we'll repeat the step description
468
5
        print "\n";
469
5
        my $spaces = 22;
470
5
        print q{ } x $spaces;
471
5
        print $argsref->{description};
472
5
        print '.' x (
473            ( $linelength - $spaces ) -
474            ( length($argsref->{description}) + length($result) + 1 )
475        );
476    }
477    else {
478
71
        print '.' x (
479            $linelength -
480            ( $argsref->{length_message} + length($result) + 1 )
481        );
482    }
483
75
100
100
    unless ( $argsref->{step_name} =~ m{^inter} && $argsref->{args}->{ask} ) {
484
74
        print "$result.";
485    }
486
75
    return 1;
487}
488
489sub _update_conftrace {
490
62
62
    my $argsref = shift;
491
62
100
    if (! defined $argsref->{conftrace}->[0]) {
492
2
        $argsref->{conftrace}->[0] = [];
493    }
494
62
62
    push @{ $argsref->{conftrace}->[0] }, $argsref->{step_name};
495
62
    my $evolved_data = {
496        options => $argsref->{conf}->{options},
497        data => $argsref->{conf}->{data},
498    };
499
62
62
    push @{ $argsref->{conftrace} }, $evolved_data;
500    {
501
62
62
        local $Storable::Deparse = 1;
502
62
        nstore( $argsref->{conftrace}, $argsref->{sto} );
503    }
504
62
    return 1;
505}
506
507 - 524
=item * C<option_or_data($arg)>

Are you tired of this construction all over the place?

    my $opt = $conf->options->get( $arg );
       $opt = $conf->data->get( $arg ) unless defined $opt;

It gives you the user-specified option for I<$arg>, and if there
isn't one, it gets it from the created data.  You do it all the
time, but oh! the wear and tear on your fingers!

Toil no more!  Use this simple construction:

    my $opt = $conf->option_or_data($arg);

and save your fingers for some real work!

=cut
525
526sub option_or_data {
527
232
232
    my $conf = shift;
528
232
    my $arg = shift;
529
530
231
    my $opt = $conf->options->get($arg);
531
231
100
    return defined $opt ? $opt : $conf->data->get($arg);
532}
533
534sub pcfreeze {
535
51
52
    my $conf = shift;
536
51
    local $Storable::Deparse = 1;
537
51
    local $Storable::Eval = 1;
538
51
    return nfreeze($conf);
539}
540
541sub replenish {
542
120
121
    my $conf = shift;
543
120
    my $serialized = shift;
544
120
120
    foreach my $k (keys %{$conf}) {
545
624
        delete $conf->{$k};
546    }
547
120
    local $Storable::Deparse = 1;
548
120
    local $Storable::Eval = 1;
549
120
120
    my %gut = %{ thaw($serialized) };
550
120
    while ( my ($k, $v) = each %gut ) {
551
504
        $conf->{$k} = $v;
552    }
553
554
120
    return;
555}
556
557 - 563
=item * C<debug()>

When C<--verbose> is requested, or when a particular configuration step is
specified in C<--verbose-step>, this method prints its arguments as a string
on STDOUT.

=cut
564
565sub debug {
566
1084
1085
    my ($conf, @messages) = @_;
567
1084
100
    if ($conf->options->get('verbose')) {
568
189
        print join('' => @messages);
569    }
570
1084
    return 1;
571}
572
573=back
574
575 - 589
=head1 CREDITS

The L</runsteps()> method is largely based on code written by Brent
Royal-Gordon C<brent@brentdax.com>.

=head1 AUTHOR

Joshua Hoblitt C<jhoblitt@cpan.org>

=head1 SEE ALSO

F<docs/configuration.pod>, L<Parrot::Configure::Data>,
L<Parrot::Configure::Utils>, L<Parrot::Configure::Step>

=cut
590
5911;
592
593# Local Variables:
594# mode: cperl
595# cperl-indent-level: 4
596# fill-column: 100
597# End:
598# vim: expandtab shiftwidth=4: