view release on metacpan or  search on metacpan

lib/App/Framework/Base.pm  view on Meta::CPAN

			$ok = 0 ;
		}
		else
		{
			$loaded{$module} = 1 ;
		}
	}
	$this->requires_ok($ok) ;
	$this->loaded(\%loaded) ;

	## First check that all required modules loaded correcly
	if (!$this->requires_ok)
	{
		my $loaded_href = $class->loaded ;
		my $failed_modules = join ', ', grep {$loaded_href->{$_}} keys %$loaded_href ;
		$this->throw_fatal("Failed to load: $failed_modules") ;	
	}

print "App::Framework::Base->new() - END\n" if $class_debug ;

	return($this) ;
}



#============================================================================================

=back

=head2 CLASS METHODS

=over 4

=cut

#============================================================================================

#-----------------------------------------------------------------------------

=item B< init_class([%args]) >

Initialises the object class variables.

=cut

sub init_class
{
	my $class = shift ;
	my (%args) = @_ ;

	# Add extra fields
	$class->add_fields(\%FIELDS, \%args) ;

	# init class
	$class->SUPER::init_class(%args) ;

}

#----------------------------------------------------------------------------

=item B<expand_keys($hash_ref, $vars_aref)>

Processes all of the HASH values, replacing any variables with their contents. The variable
values are taken from the ARRAY ref I<$vars_aref>, which is an array of hashes. Each hash
containing variable name / variable value pairs.

The HASH values being expanded can be either scalar, or an ARRAY ref. In the case of the ARRAY ref each
ARRAY entry must be a scalar (e.g. an array of file lines).

=cut

sub expand_keys
{
	my $class = shift ;
	my ($hash_ref, $vars_aref, $_state_href, $_to_expand) = @_ ;

print "expand_keys($hash_ref, $vars_aref)\n" if $class_debug;
$class->prt_data("vars=", $vars_aref, "hash=", $hash_ref) if $class_debug ;

	my %to_expand = $_to_expand ? (%$_to_expand) : (%$hash_ref) ;
	if (!$_state_href)
	{
		## Top-level
		my %data_ref ;
		
		# create state HASH
		$_state_href = {} ;
		
		# scan through hash looking for variables
		%to_expand = () ;
		foreach my $key (keys %$hash_ref)
		{
			my @vals ;
			if (ref($hash_ref->{$key}) eq 'ARRAY')
			{
				@vals = @{$hash_ref->{$key}} ;
			}
			elsif (!ref($hash_ref->{$key}))
			{
				push @vals, $hash_ref->{$key} ;
			}
			
			## Set up state - provide a level of indirection so that we can handle the case where multiple keys point to the same data
			my $ref = $hash_ref->{$key} || '' ;
			if ($ref && exists($data_ref{"$ref"}))
			{
print " + already seen data for key=$key\n" if $class_debug>=2;
				# already got created a state for this data, point to it 
				$_state_href->{$key} = $data_ref{"$ref"} ;
			}
			else
			{
print " + new state key=$key\n" if $class_debug>=2;
				my $state = 'expanded' ;
				$_state_href->{$key} = \$state ;
			}

			# save data reference
			$data_ref{"$ref"} = $_state_href->{$key} if $ref ;
			
print " + check for expansion...\n" if $class_debug>=2;
			foreach my $val (@vals)
			{
				next unless $val ;

print " + + val=$val\n" if $class_debug>=2;

				if (index($val, '$') >= 0)
				{
print " + + + needs expanding\n" if $class_debug>=2;
					$to_expand{$key}++ ;
					${$_state_href->{$key}} = 'to_expand' ;
					last ;
				}
			}
		}
	}

$class->prt_data("to expand=", \%to_expand) if $class_debug;

$class->prt_data("Hash=", $hash_ref) if $class_debug;

	## Expand them
	foreach my $key (keys %to_expand)
	{
	print " # Key=$key State=${$_state_href->{$key}}\n" if $class_debug;
	
		# skip if not valid (if called recursively with a variable that is not in the hash)
		next unless exists($hash_ref->{$key}) ;

		# Do replacement iff required
		next if ${$_state_href->{$key}} eq 'expanded' ;

		my @vals ;
		if (ref($hash_ref->{$key}) eq 'ARRAY')
		{
			foreach my $val (@{$hash_ref->{$key}})
			{
				push @vals, \$val ;
			}
		}
		elsif (!ref($hash_ref->{$key}))
		{
			push @vals, \$hash_ref->{$key} ;
		}
		
		# mark as expanding
		${$_state_href->{$key}} = 'expanding' ;		

$class->prt_data("Vals to expand=", \@vals) if $class_debug;

#use re 'debugcolor' ;

		foreach my $val_ref (@vals)
		{

	print " # Expand \"$$val_ref\" ...\n" if $class_debug;

			$$val_ref =~ s{
							(?:
								[\\\$]\$					# escaped dollar
							     \{{0,1}					# optional brace
							    (\w+)                       # find a "word" and store it in $1
							     \}{0,1}					# optional brace
						    )
							|
							(?:
							     \$                         # find a literal dollar sign
							     \{{0,1}					# optional brace
							    (\w+)                       # find a "word" and store it in $1
							     \}{0,1}					# optional brace
						     )
						}{
							my $prefix = '' ;
							my ($escaped, $var) = ($1, $2) ;
	
							$escaped ||= '' ;
							$var ||= '' ;
							
	print " # esc=\"$escaped\", prefix=\"$prefix\", var=\"$var\"\n" if $class_debug;
							
							my $replace='' ;
							if ($escaped)
							{
								$prefix = '$' ;
								$replace = $escaped ;
	print " ## escaped prefix=$prefix replace=$replace\n" if $class_debug;
	print " ## DONE\n" if $class_debug;
							}
							else
							{		
								## use current HASH values before vars				
							    if (defined $hash_ref->{$var}) 
							    {
print " ## var=$var current state=${$_state_href->{$var}}\n" if $class_debug;
							    	if (${$_state_href->{$var}} eq 'to_expand')
							    	{
print " ## var=$var call expand..\n" if $class_debug;
							    		# go expand it first
							   			$class->expand_keys($hash_ref, $vars_aref, $_state_href, {$var => 1}) ; 		
							    	}
							    	if (${$_state_href->{$var}} eq 'expanded')
							    	{
print " ## var=$var already expanded\n" if $class_debug;
								        $replace = $hash_ref->{$var};            # expand variable
							    		$replace = join("\n", @{$hash_ref->{$var}}) if (ref($hash_ref->{$var}) eq 'ARRAY') ;
							    	}
							    }
print " ## var=$var  can replace from hash=$replace\n" if $class_debug;
	
								## If not found, use vars
								if (!$replace)
								{
									## use vars 
									foreach my $href (@$vars_aref)
									{
									    if (defined $href->{$var}) 
									    {
									        $replace = $href->{$var};            # expand variable
								    		$replace = join("\n", @{$hash_ref->{$var}}) if (ref($href->{$var}) eq 'ARRAY') ;
		print " ## found var=$var replace=$replace\n" if $class_debug;
									        last ;
									    }
									}					    
								}
print " ## var=$var  can replace now=$replace\n" if $class_debug;

								if (!$replace)
								{
									$replace = "" ;
	print " ## no replacement\n" if $class_debug;
	print " ## DONE\n" if $class_debug;
								}
							}
													
	print " ## ALL DONE $key: $escaped$var = \"$prefix$replace\"\n\n" if $class_debug;
							"$prefix$replace" ;
						}egxm;	## NOTE: /m is for multiline anchors; /s is for multiline dots
		}

$class->prt_data("Hash now=", $hash_ref) if $class_debug>=2;

		# mark as expanded
		${$_state_href->{$key}} = 'expanded' ;		

$class->prt_data("State now=", $_state_href) if $class_debug>=2;
	}
}



##============================================================================================
#
#=back
#
#=head2 OBJECT DATA METHODS
#
#=over 4
#
#=cut
#
##============================================================================================


##============================================================================================
#
#=back
#
#=head2 OBJECT METHODS
#
#=over 4
#
#=cut
#
##============================================================================================


#============================================================================================
#
# PRIVATE
#
#============================================================================================

# ============================================================================================
# END OF PACKAGE

=back

=head1 DIAGNOSTICS

Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.

=head1 AUTHOR

Steve Price C<< <sdprice at cpan.org> >>

=head1 BUGS

None that I know of!

=cut


1;