File Coverage

File:lib/Parrot/Configure/Data.pm
Coverage:77.6%

linestmtbrancondsubcode
1# Copyright (C) 2001-2005, Parrot Foundation.
2
3 - 45
=pod

=head1 NAME

Parrot::Configure::Data - Configuration data container

=head1 SYNOPSIS

    use Parrot::Configure::Data;

    my $data = Parrot::Configure::Data->new;
    my @values = $data->get(@keys);
    $data->set($key1 => $value1, $key2 => $value2);
    $data->add($delimiter, $key1 => $value1, $key2 => $value2);
    my @keys = $data->keys;
    my $serialized = $data->dump(q{c}, q{*PConfig});
    $data->clean;
    $data->settrigger($key, $trigger, $cb);
    $data->gettriggers($key);
    $data->gettrigger($key, $trigger);
    $data->deltrigger($key, $trigger);

=head1 DESCRIPTION

This module provides methods by which other Parrot::Configure::* modules
can access configuration data.

The module supplies a constructor for Parrot::Configure::Data objects
and three kinds of accessors:

=over 4

=item 1  Main configuration data

=item 2  Triggers

=item 3  Data read from Perl 5's C<%Config> or Perl 5 special variables.

=back

=head1 USAGE

=cut
46
47package Parrot::Configure::Data;
48
49
100
100
100
use strict;
50
100
100
100
use warnings;
51
52
100
100
100
use Data::Dumper ();
53
54 - 78
=head2 Constructor

=over 4

=item * C<new()>

=over 4

=item * Purpose

Basic object constructor.

=item * Arguments

None.

=item * Return Value

Parrot::Configure::Data object.

=back

=back

=cut
79
80sub new {
81
371
    my $class = shift;
82
83
371
    my $self = {
84        c => {},
85        triggers => {},
86        p5 => {},
87    };
88
89
371
    bless $self, ref $class || $class;
90
371
    return $self;
91}
92
93 - 117
=head2 Methods for Main Configuration Data

=over 4

=item * C<get($key, ...)>

=over 4

=item * Purpose

Provides access to the values assigned to elements in the
Parrot::Configure object's main data structure.

=item * Arguments

List of elements found in the Parrot::Configure object's main data
structure.

=item * Return Value

List of values associated with corresponding arguments.

=back

=cut
118
119sub get {
120
30902
    my $self = shift;
121
122
30902
    my $c = $self->{c};
123
124
30902
    return @$c{@_};
125}
126
127 - 146
=item * C<< set($key => $val, ...) >>

=over 4

=item * Purpose

Modifies or creates new values in the main part of the Parrot::Configure
object's data structure..

=item * Arguments

List of C<< key => value >> pairs.

=item * Return Value

Parrot::Configure::Data object.

=back

=cut
147
148sub set {
149
24627
    my $self = shift;
150
151
24627
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
152
153
24627
    print "\nSetting Configuration Data:\n(\n" if $verbose;
154
155
24627
    while ( my ( $key, $val ) = splice @_, 0, 2 ) {
156
26268
        print "\t$key => ", defined($val) ? "'$val'" : 'undef', ",\n"
157            if $verbose;
158
26268
        $self->{c}{$key} = $val;
159
160
26268
        foreach my $trigger ( $self->gettriggers($key) ) {
161
6
            print "\tcalling trigger $trigger for $key\n" if $verbose;
162
6
            my $cb = $self->gettrigger( $key, $trigger );
163
164
6
            &$cb( $key, $val );
165        }
166    }
167
168
24627
    print ");\n" if $verbose;
169
170
24627
    return $self;
171}
172
173 - 192
=item * C<< add($delim, $key => $val, ...) >>

=over 4

=item * Purpose

Either creates a new key or appends to an existing key, with the previous/new
values joined together by C<$delim>.

=item * Arguments

Delimiter value followed by a list of C<< key => value >> pairs.

=item * Return Value

Parrot::Configure::Data object.

=back

=cut
193
194sub add {
195
45
    my $self = shift;
196
45
    my $delim = shift;
197
198
45
    while ( my ( $key, $val ) = splice @_, 0, 2 ) {
199
49
        my ($old) = $self->{c}{$key};
200
49
        if ( defined $old ) {
201
33
            $self->set( $key, "$old$delim$val" );
202        }
203        else {
204
16
            $self->set( $key, $val );
205        }
206    }
207
208
45
    return $self;
209}
210
211 - 230
=item * C<keys()>

=over 4

=item * Purpose

Provides a list of names of elements in the Parrot::Configure object's
main data structure.

=item * Arguments

None.

=item * Return Value

List of elements in the Parrot::Configure object's main data structure.

=back

=cut
231
232sub keys {
233
4
    my $self = shift;
234
235
4
4
    return keys %{ $self->{c} };
236}
237
238 - 256
=item * C<get_PConfig()>

=over 4

=item * Purpose

Slurps in L<Parrot::Config> data from previous run of I<Configure.pl>.

=item * Arguments

None.

=item * Return Value

Reference to hash holding main Parrot::Configure data structure.

=back

=cut
257
258sub get_PConfig {
259
2
    my $self = shift;
260
2
0
0
0
0
0
0
    my $res = eval <<EVAL_CONFIG;
261no strict;
262use Parrot::Config;
263\\%PConfig;
264EVAL_CONFIG
265
266
2
    if ( not defined $res ) {
267
0
        die "You cannot use --step until you have completed the full configure process\n";
268    }
269
2
    $self->{c} = $res;
270}
271
272 - 292
=item * C<get_PConfig_Temp()>

=over 4

=item * Purpose

Slurps in L<Parrot::Config> temporary data from previous run of
Configure.pl.  Only to be used when running C<gen::makefiles> plugin.

=item * Arguments

None.

=item * Return Value

Reference to hash holding that part of the main Parrot::Configure data
structure holding temporary data.

=back

=cut
293
294sub get_PConfig_Temp {
295
1
    my $self = shift;
296
1
0
0
0
0
0
0
    my $res = eval <<EVAL_CONFIG_TEMP;
297no strict;
298use Parrot::Config::Generated;
299\\%PConfig_Temp;
300EVAL_CONFIG_TEMP
301
302
1
    if ( not defined $res ) {
303
0
        die "You cannot use --step until you have completed the full configure process\n";
304    }
305
1
    $self->{c}{$_} = $res->{$_} for CORE::keys %$res;
306}
307
308 - 344
=item * C<dump()>

=over 4

=item * Purpose

Provides a L<Data::Dumper> serialized string of the objects key/value pairs
suitable for being C<eval>ed.

=item * Arguments

Two scalar arguments:

=over 4

=item 1

Key in Parrot::Configure object's data structure which is being dumped.

=item 2

Name of the dumped structure.

=back

Example:

    $conf->data->dump(q{c}, q{*PConfig});
    $conf->data->dump(q{c_temp}, q{*PConfig_Temp});

=item * Return Value

String.

=back

=cut
345
346# Data::Dumper supports Sortkeys since 2.12
347# older versions will work but obviously not sorted
348{
349    if ( defined eval { Data::Dumper->can('Sortkeys') } ) {
350        *dump = sub {
351
4
            my $self = shift;
352
4
            my ( $key, $structure ) = @_;
353
4
            Data::Dumper->new( [ $self->{$key} ], [$structure] )->Sortkeys(1)->Dump();
354        };
355    }
356    else {
357        *dump = sub {
358            my $self = shift;
359            my ( $key, $structure ) = @_;
360            Data::Dumper->new( [ $self->{$key} ], [$structure] )->Dump();
361        };
362    }
363}
364
365 - 389
=item * C<clean()>

=over 4

=item * Purpose

Deletes keys matching C</^TEMP_/> from the internal configuration store,
and copies them to a special store for temporary keys.
Keys using this naming convention are intended to be used only temporarily,
I<e.g.>  as file lists for Makefile generation.
Temporary keys are used B<only> to regenerate makefiles after configuration.

=item * Arguments

None.

=item * Return Value

Parrot::Configure::Data object.

=back

=back

=cut
390
391sub clean {
392
4
    my $self = shift;
393
394
4
367
4
    $self->{c_temp}{$_} = delete $self->{c}{$_} for grep { /^TEMP_/ } CORE::keys %{ $self->{c} };
395
396
4
    return $self;
397}
398
399 - 424
=head2 Triggers

=over 4

=item * C<settrigger($key, $trigger, $cb)>

=over 4

=item * Purpose

Set a callback on C<$key> named C<$trigger>.  Multiple triggers can be set on a
given key.  When the key is set via C<set> or C<add> then all callbacks that
are defined will be called.  Triggers are passed the key and value that was set
after it has been changed.

=item * Arguments

Accepts a key name, a trigger name, & a C<CODE> ref.

=item * Return Value

Parrot::Configure::Data object.

=back

=cut
425
426sub settrigger {
427
33
    my ( $self, $key, $trigger, $cb ) = @_;
428
429
33
    return unless defined $key and defined $trigger and defined $cb;
430
431
33
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
432
433
33
    print "Setting trigger $trigger on configuration key $key\n",
434        if $verbose;
435
436
33
    $self->{triggers}{$key}{$trigger} = $cb;
437
438
33
    return $self;
439}
440
441 - 459
=item * C<gettriggers($key)>

=over 4

=item * Purpose

Get the names of all triggers set for C<$key>.

=item * Arguments

String holding single key name.

=item * Return Value

List of triggers set for that key.

=back

=cut
460
461sub gettriggers {
462
26272
    my ( $self, $key ) = @_;
463
464
26272
    return unless defined $self->{triggers}{$key};
465
466
6
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
467
468
6
    print "Looking up all triggers on configuration key $key\n"
469        if $verbose;
470
471
6
6
    return CORE::keys %{ $self->{triggers}{$key} };
472}
473
474 - 492
=item * C<gettrigger($key, $trigger)>

=over 4

=item * Purpose

Get the callback set for C<$key> under the name C<$trigger>

=item * Arguments

Accepts a key name & a trigger name.

=item * Return Value

C<CODE> ref.

=back

=cut
493
494sub gettrigger {
495
16
    my ( $self, $key, $trigger ) = @_;
496
497    return
498
16
        unless defined $self->{triggers}{$key}
499            and defined $self->{triggers}{$key}{$trigger};
500
501
11
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
502
503
11
    print "Looking up trigger $trigger on configuration key $key\n"
504        if $verbose;
505
506
11
    return $self->{triggers}{$key}{$trigger};
507}
508
509 - 527
=item * C<deltrigger($key, $trigger)>

=over 4

=item * Purpose

Removes the trigger on C<$key> named by C<$trigger>

=item * Arguments

Accepts a key name & a trigger name.

=item * Return Value

Parrot::Configure::Data object.

=back

=cut
528
529sub deltrigger {
530
9
    my ( $self, $key, $trigger ) = @_;
531
532    return
533
9
        unless defined $self->{triggers}{$key}
534            and defined $self->{triggers}{$key}{$trigger};
535
536
8
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
537
538
8
    print "Removing trigger $trigger on configuration key $key\n"
539        if $verbose;
540
541
8
    delete $self->{triggers}{$key}{$trigger};
542
543
8
    return $self;
544}
545
546=back
547
548 - 580
=head2 Methods for Perl 5 Data


=over 4

=item * C<get_p5($key, ...)>

=over 4

=item * Purpose

Retrieve data originally derived from the Perl 5 environment during
configuration step C<init::defaults> and stored in a special part of the
Parrot::Configure::Data object.

=item * Arguments

List of elements found in the Perl 5-related part of the
Parrot::Configure object's data structure.

=item * Return Value

List of values associated with corresponding arguments.

=item * Note

Once data from Perl 5's C<%Config> or special variables has been stored
in configuration step C<init::defaults>, C<%Config> and the special
variables should not be further accessed.  Use this method instead.

=back

=cut
581
582sub get_p5 {
583
87
    my $self = shift;
584
585
87
    my $p5 = $self->{p5};
586
587
87
    return @$p5{@_};
588}
589
590 - 624
=item * C<< set_p5($key => $val, ...) >>

=over 4

=item * Purpose

Looks up values from either (a) the C<%Config>, located in Config.pm
and imported via C<use Config;>, associated with the instance of Perl
(C<$^X>) used to run I<Configure.pl> and assigns those values to a
special part of the Parrot::Configure::Data object.

=item * Arguments

List of C<< key => value >> pairs.  If the key being set is from
C<%Config>, the corresponding value should have the same name.  If,
however, the key being set is a Perl 5 special variable (I<e.g.>,
C<%^O>), the corresponding value should be the 'English' name of that
special variable as documented in L<perlvar> (less the initial C<$>, of
course).

=item * Return Value

Parrot::Configure::Data object.

=item * Examples

=item * Note

This method should B<only> be used in configuration step
C<init::defaults>.  It is B<not> the method used to assign values to the
main Parrot::Configure data structure; use C<set()> (above) instead.

=back

=cut
625
626sub set_p5 {
627
16
    my $self = shift;
628
629
16
    my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2;
630
631
16
    print "\nSetting Configuration Data:\n(\n" if $verbose;
632
633
16
    while ( my ( $key, $val ) = splice @_, 0, 2 ) {
634
1392
        print "\t$key => ", defined($val) ? "'$val'" : 'undef', ",\n"
635            if $verbose;
636
1392
        $self->{p5}{$key} = $val;
637
638    }
639
640
16
    print ");\n" if $verbose;
641
642
16
    return $self;
643}
644
645 - 667
=item * C<keys_p5()>

=over 4

=item * Purpose

Provides a list of names of elements in the Parrot::Configure object's
main data structure.

=item * Arguments

None.

=item * Return Value

List of elements in the part of the Parrot::Configure object's data
structure storing Perl 5 configuration data.

=back

=back

=cut
668
669sub keys_p5 {
670
5
    my $self = shift;
671
672
5
5
    return CORE::keys %{ $self->{p5} };
673}
674
675 - 688
=head1 CREDITS

Based largely 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>, L<Parrot::Configure::Step>,
L<Parrot::Configure::Step>

=cut
689
6901;
691
692# Local Variables:
693# mode: cperl
694# cperl-indent-level: 4
695# fill-column: 100
696# End:
697# vim: expandtab shiftwidth=4: