1# Copyright (C) 2001-2005, Parrot Foundation. 2 3=pod 4 5=head1 NAME 6 7Parrot::Configure::Data - Configuration data container 8 9=head1 SYNOPSIS 10 11 use Parrot::Configure::Data; 12 13 my $data = Parrot::Configure::Data->new; 14 my @values = $data->get(@keys); 15 $data->set($key1 => $value1, $key2 => $value2); 16 $data->add($delimiter, $key1 => $value1, $key2 => $value2); 17 my @keys = $data->keys; 18 my $serialized = $data->dump(q{c}, q{*PConfig}); 19 $data->clean; 20 $data->settrigger($key, $trigger, $cb); 21 $data->gettriggers($key); 22 $data->gettrigger($key, $trigger); 23 $data->deltrigger($key, $trigger); 24 25=head1 DESCRIPTION 26 27This module provides methods by which other Parrot::Configure::* modules 28can access configuration data. 29 30The module supplies a constructor for Parrot::Configure::Data objects 31and three kinds of accessors: 32 33=over 4 34 35=item 1 Main configuration data 36 37=item 2 Triggers 38 39=item 3 Data read from Perl 5's C<%Config> or Perl 5 special variables. 40 41=back 42 43=head1 USAGE 44 45=cut 46 47package Parrot::Configure::Data; 48 49use strict; 50use warnings; 51 52use Data::Dumper (); 53 54=head2 Constructor 55 56=over 4 57 58=item * C<new()> 59 60=over 4 61 62=item * Purpose 63 64Basic object constructor. 65 66=item * Arguments 67 68None. 69 70=item * Return Value 71 72Parrot::Configure::Data object. 73 74=back 75 76=back 77 78=cut 79 80sub new { 81 my $class = shift; 82 83 my $self = { 84 c => {}, 85 triggers => {}, 86 p5 => {}, 87 }; 88 89 bless $self, ref $class || $class; 90 return $self; 91} 92 93=head2 Methods for Main Configuration Data 94 95=over 4 96 97=item * C<get($key, ...)> 98 99=over 4 100 101=item * Purpose 102 103Provides access to the values assigned to elements in the 104Parrot::Configure object's main data structure. 105 106=item * Arguments 107 108List of elements found in the Parrot::Configure object's main data 109structure. 110 111=item * Return Value 112 113List of values associated with corresponding arguments. 114 115=back 116 117=cut 118 119sub get { 120 my $self = shift; 121 122 my $c = $self->{c}; 123 124 return @$c{@_}; 125} 126 127=item * C<< set($key => $val, ...) >> 128 129=over 4 130 131=item * Purpose 132 133Modifies or creates new values in the main part of the Parrot::Configure 134object's data structure.. 135 136=item * Arguments 137 138List of C<< key => value >> pairs. 139 140=item * Return Value 141 142Parrot::Configure::Data object. 143 144=back 145 146=cut 147 148sub set { 149 my $self = shift; 150 151 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 152 153 print "\nSetting Configuration Data:\n(\n" if $verbose; 154 155 while ( my ( $key, $val ) = splice @_, 0, 2 ) { 156 print "\t$key => ", defined($val) ? "'$val'" : 'undef', ",\n" 157 if $verbose; 158 $self->{c}{$key} = $val; 159 160 foreach my $trigger ( $self->gettriggers($key) ) { 161 print "\tcalling trigger $trigger for $key\n" if $verbose; 162 my $cb = $self->gettrigger( $key, $trigger ); 163 164 &$cb( $key, $val ); 165 } 166 } 167 168 print ");\n" if $verbose; 169 170 return $self; 171} 172 173=item * C<< add($delim, $key => $val, ...) >> 174 175=over 4 176 177=item * Purpose 178 179Either creates a new key or appends to an existing key, with the previous/new 180values joined together by C<$delim>. 181 182=item * Arguments 183 184Delimiter value followed by a list of C<< key => value >> pairs. 185 186=item * Return Value 187 188Parrot::Configure::Data object. 189 190=back 191 192=cut 193 194sub add { 195 my $self = shift; 196 my $delim = shift; 197 198 while ( my ( $key, $val ) = splice @_, 0, 2 ) { 199 my ($old) = $self->{c}{$key}; 200 if ( defined $old ) { 201 $self->set( $key, "$old$delim$val" ); 202 } 203 else { 204 $self->set( $key, $val ); 205 } 206 } 207 208 return $self; 209} 210 211=item * C<keys()> 212 213=over 4 214 215=item * Purpose 216 217Provides a list of names of elements in the Parrot::Configure object's 218main data structure. 219 220=item * Arguments 221 222None. 223 224=item * Return Value 225 226List of elements in the Parrot::Configure object's main data structure. 227 228=back 229 230=cut 231 232sub keys { 233 my $self = shift; 234 235 return keys %{ $self->{c} }; 236} 237 238=item * C<get_PConfig()> 239 240=over 4 241 242=item * Purpose 243 244Slurps in L<Parrot::Config> data from previous run of I<Configure.pl>. 245 246=item * Arguments 247 248None. 249 250=item * Return Value 251 252Reference to hash holding main Parrot::Configure data structure. 253 254=back 255 256=cut 257 258sub get_PConfig { 259 my $self = shift; 260 my $res = eval <<EVAL_CONFIG; 261no strict; 262use Parrot::Config; 263\\%PConfig; 264EVAL_CONFIG 265 266 if ( not defined $res ) { 267 die "You cannot use --step until you have completed the full configure process\n"; 268 } 269 $self->{c} = $res; 270} 271 272=item * C<get_PConfig_Temp()> 273 274=over 4 275 276=item * Purpose 277 278Slurps in L<Parrot::Config> temporary data from previous run of 279Configure.pl. Only to be used when running C<gen::makefiles> plugin. 280 281=item * Arguments 282 283None. 284 285=item * Return Value 286 287Reference to hash holding that part of the main Parrot::Configure data 288structure holding temporary data. 289 290=back 291 292=cut 293 294sub get_PConfig_Temp { 295 my $self = shift; 296 my $res = eval <<EVAL_CONFIG_TEMP; 297no strict; 298use Parrot::Config::Generated; 299\\%PConfig_Temp; 300EVAL_CONFIG_TEMP 301 302 if ( not defined $res ) { 303 die "You cannot use --step until you have completed the full configure process\n"; 304 } 305 $self->{c}{$_} = $res->{$_} for CORE::keys %$res; 306} 307 308=item * C<dump()> 309 310=over 4 311 312=item * Purpose 313 314Provides a L<Data::Dumper> serialized string of the objects key/value pairs 315suitable for being C<eval>ed. 316 317=item * Arguments 318 319Two scalar arguments: 320 321=over 4 322 323=item 1 324 325Key in Parrot::Configure object's data structure which is being dumped. 326 327=item 2 328 329Name of the dumped structure. 330 331=back 332 333Example: 334 335 $conf->data->dump(q{c}, q{*PConfig}); 336 $conf->data->dump(q{c_temp}, q{*PConfig_Temp}); 337 338=item * Return Value 339 340String. 341 342=back 343 344=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 my $self = shift; 352 my ( $key, $structure ) = @_; 353 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=item * C<clean()> 366 367=over 4 368 369=item * Purpose 370 371Deletes keys matching C</^TEMP_/> from the internal configuration store, 372and copies them to a special store for temporary keys. 373Keys using this naming convention are intended to be used only temporarily, 374I<e.g.> as file lists for Makefile generation. 375Temporary keys are used B<only> to regenerate makefiles after configuration. 376 377=item * Arguments 378 379None. 380 381=item * Return Value 382 383Parrot::Configure::Data object. 384 385=back 386 387=back 388 389=cut 390 391sub clean { 392 my $self = shift; 393 394 $self->{c_temp}{$_} = delete $self->{c}{$_} for grep { /^TEMP_/ } CORE::keys %{ $self->{c} }; 395 396 return $self; 397} 398 399=head2 Triggers 400 401=over 4 402 403=item * C<settrigger($key, $trigger, $cb)> 404 405=over 4 406 407=item * Purpose 408 409Set a callback on C<$key> named C<$trigger>. Multiple triggers can be set on a 410given key. When the key is set via C<set> or C<add> then all callbacks that 411are defined will be called. Triggers are passed the key and value that was set 412after it has been changed. 413 414=item * Arguments 415 416Accepts a key name, a trigger name, & a C<CODE> ref. 417 418=item * Return Value 419 420Parrot::Configure::Data object. 421 422=back 423 424=cut 425 426sub settrigger { 427 my ( $self, $key, $trigger, $cb ) = @_; 428 429 return unless defined $key and defined $trigger and defined $cb; 430 431 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 432 433 print "Setting trigger $trigger on configuration key $key\n", 434 if $verbose; 435 436 $self->{triggers}{$key}{$trigger} = $cb; 437 438 return $self; 439} 440 441=item * C<gettriggers($key)> 442 443=over 4 444 445=item * Purpose 446 447Get the names of all triggers set for C<$key>. 448 449=item * Arguments 450 451String holding single key name. 452 453=item * Return Value 454 455List of triggers set for that key. 456 457=back 458 459=cut 460 461sub gettriggers { 462 my ( $self, $key ) = @_; 463 464 return unless defined $self->{triggers}{$key}; 465 466 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 467 468 print "Looking up all triggers on configuration key $key\n" 469 if $verbose; 470 471 return CORE::keys %{ $self->{triggers}{$key} }; 472} 473 474=item * C<gettrigger($key, $trigger)> 475 476=over 4 477 478=item * Purpose 479 480Get the callback set for C<$key> under the name C<$trigger> 481 482=item * Arguments 483 484Accepts a key name & a trigger name. 485 486=item * Return Value 487 488C<CODE> ref. 489 490=back 491 492=cut 493 494sub gettrigger { 495 my ( $self, $key, $trigger ) = @_; 496 497 return 498 unless defined $self->{triggers}{$key} 499 and defined $self->{triggers}{$key}{$trigger}; 500 501 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 502 503 print "Looking up trigger $trigger on configuration key $key\n" 504 if $verbose; 505 506 return $self->{triggers}{$key}{$trigger}; 507} 508 509=item * C<deltrigger($key, $trigger)> 510 511=over 4 512 513=item * Purpose 514 515Removes the trigger on C<$key> named by C<$trigger> 516 517=item * Arguments 518 519Accepts a key name & a trigger name. 520 521=item * Return Value 522 523Parrot::Configure::Data object. 524 525=back 526 527=cut 528 529sub deltrigger { 530 my ( $self, $key, $trigger ) = @_; 531 532 return 533 unless defined $self->{triggers}{$key} 534 and defined $self->{triggers}{$key}{$trigger}; 535 536 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 537 538 print "Removing trigger $trigger on configuration key $key\n" 539 if $verbose; 540 541 delete $self->{triggers}{$key}{$trigger}; 542 543 return $self; 544} 545 546=back 547 548=head2 Methods for Perl 5 Data 549 550 551=over 4 552 553=item * C<get_p5($key, ...)> 554 555=over 4 556 557=item * Purpose 558 559Retrieve data originally derived from the Perl 5 environment during 560configuration step C<init::defaults> and stored in a special part of the 561Parrot::Configure::Data object. 562 563=item * Arguments 564 565List of elements found in the Perl 5-related part of the 566Parrot::Configure object's data structure. 567 568=item * Return Value 569 570List of values associated with corresponding arguments. 571 572=item * Note 573 574Once data from Perl 5's C<%Config> or special variables has been stored 575in configuration step C<init::defaults>, C<%Config> and the special 576variables should not be further accessed. Use this method instead. 577 578=back 579 580=cut 581 582sub get_p5 { 583 my $self = shift; 584 585 my $p5 = $self->{p5}; 586 587 return @$p5{@_}; 588} 589 590=item * C<< set_p5($key => $val, ...) >> 591 592=over 4 593 594=item * Purpose 595 596Looks up values from either (a) the C<%Config>, located in Config.pm 597and imported via C<use Config;>, associated with the instance of Perl 598(C<$^X>) used to run I<Configure.pl> and assigns those values to a 599special part of the Parrot::Configure::Data object. 600 601=item * Arguments 602 603List of C<< key => value >> pairs. If the key being set is from 604C<%Config>, the corresponding value should have the same name. If, 605however, the key being set is a Perl 5 special variable (I<e.g.>, 606C<%^O>), the corresponding value should be the 'English' name of that 607special variable as documented in L<perlvar> (less the initial C<$>, of 608course). 609 610=item * Return Value 611 612Parrot::Configure::Data object. 613 614=item * Examples 615 616=item * Note 617 618This method should B<only> be used in configuration step 619C<init::defaults>. It is B<not> the method used to assign values to the 620main Parrot::Configure data structure; use C<set()> (above) instead. 621 622=back 623 624=cut 625 626sub set_p5 { 627 my $self = shift; 628 629 my $verbose = defined $self->get('verbose') && $self->get('verbose') == 2; 630 631 print "\nSetting Configuration Data:\n(\n" if $verbose; 632 633 while ( my ( $key, $val ) = splice @_, 0, 2 ) { 634 print "\t$key => ", defined($val) ? "'$val'" : 'undef', ",\n" 635 if $verbose; 636 $self->{p5}{$key} = $val; 637 638 } 639 640 print ");\n" if $verbose; 641 642 return $self; 643} 644 645=item * C<keys_p5()> 646 647=over 4 648 649=item * Purpose 650 651Provides a list of names of elements in the Parrot::Configure object's 652main data structure. 653 654=item * Arguments 655 656None. 657 658=item * Return Value 659 660List of elements in the part of the Parrot::Configure object's data 661structure storing Perl 5 configuration data. 662 663=back 664 665=back 666 667=cut 668 669sub keys_p5 { 670 my $self = shift; 671 672 return CORE::keys %{ $self->{p5} }; 673} 674 675=head1 CREDITS 676 677Based largely on code written by Brent Royal-Gordon C<brent@brentdax.com>. 678 679=head1 AUTHOR 680 681Joshua Hoblitt C<jhoblitt@cpan.org> 682 683=head1 SEE ALSO 684 685F<docs/configuration.pod>, L<Parrot::Configure>, L<Parrot::Configure::Step>, 686L<Parrot::Configure::Step> 687 688=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: 698