| File: | lib/Parrot/Configure/Data.pm |
| Coverage: | 77.6% |
| line | stmt | bran | cond | sub | code |
|---|---|---|---|---|---|
| 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 | |||||
| 47 | package 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 | |||||
| 80 | sub 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 | |||||
| 119 | sub 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 | |||||
| 148 | sub 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 | |||||
| 194 | sub 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 | |||||
| 232 | sub 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 | |||||
| 258 | sub get_PConfig { | ||||
| 259 | 2 | my $self = shift; | |||
| 260 | 2 0 0 0 0 0 0 | my $res = eval <<EVAL_CONFIG; | |||
| 261 | no strict; | ||||
| 262 | use Parrot::Config; | ||||
| 263 | \\%PConfig; | ||||
| 264 | EVAL_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 | |||||
| 294 | sub get_PConfig_Temp { | ||||
| 295 | 1 | my $self = shift; | |||
| 296 | 1 0 0 0 0 0 0 | my $res = eval <<EVAL_CONFIG_TEMP; | |||
| 297 | no strict; | ||||
| 298 | use Parrot::Config::Generated; | ||||
| 299 | \\%PConfig_Temp; | ||||
| 300 | EVAL_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 | |||||
| 391 | sub 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 | |||||
| 426 | sub 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 | |||||
| 461 | sub 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 | |||||
| 494 | sub 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 | |||||
| 529 | sub 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 | |||||
| 582 | sub 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 | |||||
| 626 | sub 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 | |||||
| 669 | sub 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 | |||||
| 690 | 1; | ||||
| 691 | |||||
| 692 | # Local Variables: | ||||
| 693 | # mode: cperl | ||||
| 694 | # cperl-indent-level: 4 | ||||
| 695 | # fill-column: 100 | ||||
| 696 | # End: | ||||
| 697 | # vim: expandtab shiftwidth=4: | ||||