view release on metacpan or  search on metacpan

lib/Activator/Registry.pm  view on Meta::CPAN

package Activator::Registry;
use YAML::Syck;
use base 'Class::StrongSingleton';
use Activator::Log qw( :levels );
use Data::Dumper;
use Hash::Merge;
use Activator::Exception;
use Exception::Class::TryCatch;

=head1 NAME

Activator::Registry - provide a registry based on YAML file(s)

=head1 SYNOPSIS


  use Activator::Registry;

  #### register $value to $key in realm $realm
  Activator::Registry->register( $key, $value, $realm );

  #### register $value to $key in default realm
  Activator::Registry->register( $key, $value );

  #### get value for $key from $realm
  Activator::Registry->get( $key, $realm );

  #### get value for $key from default realm
  Activator::Registry->get( $key );

  #### get a deep value for $key from default realm
  #### this form throws exception for invalid keys
  $key = 'top->deep->deeper';
  try eval {
     Activator::Registry->get( $key );
  }

  #### register YAML file into realm
  Activator::Registry->register_file( $file, $realm );

  #### register hash into realm
  Activator::Registry->register_hash( $mode, $hashref, $realm );

  #### use ${} syntax in your registry for variables
  Activator::Registry->replace_in_realm( 'default', $replacements_hashref );

=head1 DESCRIPTION

This module provides global access to a registry of key-value pairs.
It is implemented as a singleton, so you can use this Object Oriented
or staticly with arrow notation. It supports getting and setting of
deeply nested objects. Setting can be done via YAML configuration
files.

=head1 CONFIGURATION FILES

Configuration files are YAML files.

=head2 Registry Within Another Configuration File

You can have a registry be a stand alone file, or live within a
configuration file used for other purposes. If you wish your registry
to be only a subset of a larger YAML file, put the desired hierarchy
in a top level key C<Activator::Registry>. If that key exists, only
that part of the YAML file will be registered.

lib/Activator/Registry.pm  view on Meta::CPAN

=head2 do_replacements ( $string, $replacements )

Helper subroutine to allow recursive replacements of C<${}> notation
with values in C<$replacements>. Returns the new value.

=cut

sub do_replacements {
    my ( $pkg, $string, $replacements, $depth ) = @_;

    my ( $replacement_str, $num_replaced ) = $pkg->get_replaced_string( $string, $replacements );

    if ( $num_replaced > 0 && $replacement_str =~ /\$\{[^\}]+\}/ ) {
	$replacement_str = $pkg->do_replacements( $replacement_str, $replacements, $depth+1 );
    }

    $string = $replacement_str;
    return $string;
}

=head2 get_replaced_string( $target, $replacements )

In scalar context, return the value of C<$target> after replacing
variables matching C<${}> notation with the values in
C<$replacements>. If a variable exists, but there is no replacement
value, it is not changed. In list context, returns the string and the
number of replacements.

=cut

sub get_replaced_string {
    my ( $pkg, $target, $replacements ) = @_;
    my $num_replaced = 0;
    my @matches = ( $target =~ /\$\{([^\}]+)/g );
    if ( @matches ) {
	TRACE( "found variables: (".join (',',@matches) . ") in target '$target'");
	map {
	    my $replace = $replacements->{ $_ };
	    if ( defined $replace ) {
		$target =~ s/\$\{$_\}/$replace/g;
		TRACE("Replaced '\${$_}' with '$replace'. target is '$target'");
		$num_replaced++;
	    } else {
		# TODO: figure out how to warn the context of this
		WARN("Skipped variable '$_'. Does not have a replacement value.");
	    }
	} @matches;
    }
    else {
	TRACE( "No variables to replace in '$target'");
    }
    return wantarray ? ( $target, $num_replaced ) : $target;
}

# register_hash helpers for when using SAFE_LEFT_PRECEDENCE merging
# TODO (not currently used)
sub die_array_scalar {

    die "Can't coerce ARRAY into SCALAR\n" .
      Data::Dumper->Dump( [ $_[0], $_[1] ],
			  [ qw( ARRAY SCALAR ) ] );
}

sub die_hash_scalar {
    die "Can't coerce HASH into SCALAR\n" .
      Data::Dumper->Dump( [ $_[0], $_[1] ],
			  [ qw( HASH SCALAR ) ] );
}

sub die_hash_array {
    die "Can't coerce HASH into ARRAY\n" .
      Data::Dumper->Dump( [ $_[0], $_[1] ],
			  [ qw( HASH ARRAY ) ] );
}

sub die_scalar_hash {
    die "Can't coerce SCALAR into HASH\n" .
      Data::Dumper->Dump( [ $_[0], $_[1] ],
			  [ qw( SCALAR HASH ) ] );
}

sub die_array_hash {
    die "Can't coerce ARRAY into HASH\n" .
      Data::Dumper->Dump( [ $_[0], $_[1] ],
			  [ qw( ARRAY HASH ) ] );
}



=head1 FUTURE WORK

=over

=item * Fix warning messages

If you create a script that uses this module (or some other activator
module that depends on this module), the warning messages are rather
arcane. This script:

  #!/usr/bin/perl
  use strict;
  use warnings;
  use Activator::DB;
  Activator::DB->getrow( 'select * from some_table', [],  connect->'default');

Run this way:

  ./test.pl

Produces this error:

  activator_db_config missing You must define the key "Activator::DB" or "Activator->DB" in your project configuration

Probably should say something about the fact that you should have run it like this:

  ACT_REG_YAML_FILE=/path/to/registry.yml ./test.pl


=item * Utilize other merge methods

Only the default merge mechanism for L<Hash::Merge> is used. It'd be
more robust to support other mechanisms as well.

=back

=head1 See Also

L<Activator::Log>, L<Activator::Exception>, L<YAML::Syck>,
L<Exception::Class::TryCatch>, L<Class::StrongSingleton>

=head1 AUTHOR

Karim A. Nassar ( karim.nassar@acm.org )

=head1 License

The Activator::Registry module is Copyright (c) 2007 Karim A. Nassar.

You may distribute under the terms of either the GNU General Public
License or the Artistic License, or as specified in the Perl README file.

=cut