view release on metacpan or  search on metacpan

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

	if ( UNIVERSAL::isa( $hashref->{ $key }, 'HASH')) {
	    $pkg->replace_in_hashref( $hashref->{ $key }, $replacements );
	}

	# if key is an array, do replacements for each item
	elsif ( UNIVERSAL::isa( $hashref->{ $key }, 'ARRAY')) {
	    for( my $i = 0; $i < @{ $hashref->{ $key } }; $i++ ) {
		@{ $hashref->{ $key }}[ $i ] =
		  $pkg->do_replacements( @{ $hashref->{ $key }}[ $i ],
					 $replacements,
					 0 );
	    }
	}

	# if key is a string just do the replacment for the string
	else {
	    $hashref->{ $key } =
	      $pkg->do_replacements( $hashref->{ $key },
				     $replacements,
				     0 );
	}
    }
}

=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