view release on metacpan or  search on metacpan

lib/Agent/TCLI/Command.pm  view on Meta::CPAN

		{
			push( @aliases , @{ $self->Aliases( $contexts[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ $c->[3] } ) } );
		}
		if ( defined( $contexts[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ '*U' } ) )
		{
			# This would allow hashes under *U which is not supported by Control.pm
			push( @aliases , @{ $self->Aliases( $contexts[$$self]{ $c->[0] }{ $c->[1] }{ $c->[2] }{ '*U' } ) } );
		}
	}

	$self->Verbose("Usages: out \$c dump",4,$c);
	$self->Verbose("Usages: out aliases dump",4,\@aliases);
	$self->Verbose("Usages: contexts dump",3, $contexts[$$self] ) unless @aliases;
	return ( \@aliases );
} # End Usages

=item Aliases (  context_hash_key  )

Return aliases for specific context hash key.

An internal method that takes a context hash key and returns all the
aliases for that specific key. The aliases could be an array, hash
or scalar and this function simplifies that logic. It returns a
hash keyed on aliases of the command object.

If one has only a context, then use Usages which will call
Aliases correctly.

=cut

sub Aliases {
	my ($self, $context_hash_key) = @_;
	$self->Verbose("Aliases: context_hash_key dump",3,$context_hash_key);
	my @aliases;
	if ( ref( $context_hash_key ) =~ /ARRAY/ )
	{
		# There is a list of aliases to add.
		push( @aliases ,  @{$context_hash_key} );
#		%aliases = map { $_ => $self }  @{$context_hash_key} };
	}
	elsif ( ref( $context_hash_key ) =~ /HASH/ )
	{
		# There are context shifts to add.
		foreach my $key (keys %{$context_hash_key} )
		{
			push( @aliases , $key  ) unless ( $key =~ qr(\*U) );
		}
#		%aliases = map { $_ => $self }  keys %{$context_hash_key};
	}
	else
	{
		# There is a single alias to add.
		push( @aliases , $context_hash_key );
#		%aliases = ( $context_hash_key => $self );
	}
	return (\@aliases);
} # End Aliases

#sub RawCommand {
#	my $self = shift;
##    my %cmd = validate( @_, {
##        help_text => { type => Params::Validate::SCALAR },  #required
##        usage     => { type => Params::Validate::SCALAR },  #required
##        topic     => { optional => 1, type => Params::Validate::SCALAR },
##        name      => { type => Params::Validate::SCALAR },  #required
##        command   => { type => ( Params::Validate::SCALAR | Params::Validate::CODEREF ) }, #required
##        context	  => { optional => 1, type => Params::Validate::ARRAYREF },
##        style     => { optional => 1, type => Params::Validate::SCALAR },
##        start     => { optional => 1, type => Params::Validate::CODEREF },
##        handler   => { optional => 1, type => Params::Validate::SCALAR },
##        stop      => { optional => 1, type => Params::Validate::CODEREF },
##    } );
#
#	my %cmdhash = (
#		'name'		=> $name[$$self],
#        'help'		=> $help[$$self],
#        'usage'		=> $usage[$$self],
#        'command' 	=> $command[$$self],
#	);
#	$cmdhash{'topic'} 	= $topic[$$self] 	if (defined($topic[$$self]));
#	$cmdhash{'contexts'}	= $contexts[$$self] if (defined($contexts[$$self]));
#	$cmdhash{'call_style'}	= $call_style[$$self] if (defined($call_style[$$self]));
#	$cmdhash{'handler'}	= $handler[$$self] 	if (defined($handler[$$self]));
#	$cmdhash{'start'}	= $start[$$self] 	if (defined($start[$$self]));
#	$cmdhash{'stop'}	= $stop[$$self] 	if (defined($stop[$$self]));
#
#  	return ( \%cmdhash );
#}

=item GetoptLucid( $kernel, $request)

Returns an option hash keyed on parameter after the arguments have bee parsed
by Getopt::Lucid. Will respond itself if there is an error and return nothing.

Takes the POE Kernel and the request as args.

=cut

sub GetoptLucid {
	my ($self, $kernel, $request, $package) = @_;

	my (@options, $func);

	# Creat an array for Getopt::Lucid
	foreach my $param ( values %{ $self->parameters }  )
	{
#		my $name = defined($param->aliases)
#			? $param->name.'|'.$param->aliases
#			: $param->name;
		my $name = $param->name;

		# don't put as required if default is set.
		if ( exists $self->required->{$name} &&
			( defined ($package) &&
			 not defined( $package->$name ) ) )
		{
			no strict 'refs';
			push(@options, $param->type->($param->Alias)->required() );
		}
		else
		{
			no strict 'refs';
			push(@options, $param->type->($param->Alias) );
		}
	}

	$self->Verbose("GetoptLucid: options ",2,\@options);

	my $opt;

#	$self->Verbose("GetoptLucid: request args",1,$request->args );

	# Parse the args using parameters.
	eval {$opt = Getopt::Lucid->getopt(
		\@options,
		$request->args,
		);
	};

	# If it went bad, error and return nothing.
	if( $@ )
	{
		$self->Verbose('GetoptLucid: got ('.$@.') ');
		$request->Respond($kernel,  "Invalid Args: $@ !", 400);
		return (0);
	}

	return( $opt );
}

=item Validate( <kernel>, <request>, <package> )

Returns a hash keyed on parameter after the arguments have been parsed
by Getopt::Lucid and validated by FormValidator::Simple as per the constraints
specified in the Parameter or Command definitions.
Will respond itself if there is an error and return nothing.

Takes the POE Kernel, the Request, and the Package as args.

=cut

sub Validate {
	my ($self, $kernel, $request, $package) = @_;

	# Getopt will send error if problem.
	return unless (my $opt  = $self->GetoptLucid($kernel, $request, $package) );

#	my %args = $opt->options;
	my %args = $self->ApplyDefaults($opt, $package, $request->input );

#	$self->Verbose("Validate: param",1,\%args);
#	$self->Verbose('Validate: $request->input ',1,$request->input);

	# are there any left?
	if (keys %args == 0 )
	{
		$self->Verbose('Validate: failed no valid args');
		$request->Respond($kernel,"No valid args found!", 400);
		return (0);
	}

	my (@profile, %input, $txt);

	# Creat an array for Form::Validator
	# and an %input without objects or things that aren't constrained
	foreach my $check ( values %{ $self->parameters }  )
	{
		if ( defined($check->constraints ) )
		{
			push(@profile, $check->name, $check->constraints );
			$input{ $check->name } = $args{ $check->name }
				if	(!ref( $args{ $check->name } ) );
		}
	}

	$self->Verbose("Validate: profile ",2,\@profile);

#	$self->Verbose("Validate: input",1,\%input);

	my $results = FormValidator::Simple->check( \%input => \@profile);

    if ( $results->has_error ) {
        foreach my $key ( @{ $results->error() } ) {
            foreach my $type ( @{ $results->error($key) } ) {
                $txt .= "Invalid: $key not $type \n";
                $txt .= "$key: ".$input{$key}." \n";
            }
        }
		$self->Verbose('Validate: failed ('.$txt.') ');
		$request->Respond($kernel,$txt, 400);
		return (0);
    }

	# create class objects if necessary

lib/Agent/TCLI/Command.pm  view on Meta::CPAN

	return(\%args);
}

=item ApplyDefaults( <param_hash>, <package>, <input> )

Returns a hash keyed on parameter after the defaults from the Package
attributes have been applied. This is used during the Validate method.

=cut

sub ApplyDefaults {
	my ($self, $opt, $package, $input ) = @_;

	my %defaults;

	# Creat defaults hash for Getopt::Lucid
	foreach my $param ( values %{ $self->parameters }  )
	{
		# add to the default hash if an attribute exists in the package
		my $acc = $param->name;
		if (defined( $package ) &&
			$package->can( $acc ) &&
			defined( $package->$acc )
			)
		{
			$defaults{$acc} = $package->$acc;
		}
	}

	$self->Verbose("ApplyDefaults: defaults ",4,\%defaults);

	# turn results into a hash and return
	my %opt;

	# merge with defaults
	%opt = $opt->replace_defaults( %defaults );

#	$self->Verbose("ApplyDefaults: opt before cleansing ",1,\%opt);

	my $regex;
	# Hash has empty values for args not supplied. Take them out (again).
	foreach my $key ( keys %opt )
	{
		$regex = $self->parameters->{$key}->Alias;
		delete($opt{$key}) if (
			(not $opt{$key} ) &&        		# the value is blank or zero
			( $input !~ qr($regex) ||		# it was not in the input
			not ( defined( $package ) &&	# it is not defined in the defaults
			$package->can( $key ) &&
			defined( $package->$key ) ) )
			);
	}

	return( %opt );
}

=item BuildCommandLine( <param_hash>, <with_cmd> )

Returns a hash keyed on parameter after the arguments have been parsed
by Getopt::Lucid and validated by FormValidator::Simple as per the constraints
specified in the Parameter or Command definitions.
Will respond itself if there is an error and return nothing.

Takes the POE Kernel, the Request, and the Package as args.

=cut

sub BuildCommandLine {
	my ($self, $param_hash, $with_cmd ) = @_;

	my $command_line = $with_cmd ? $self->command." " : '';

	$command_line .= $self->cl_options." " if defined($self->cl_options);

	foreach my $param (sort keys %{$param_hash} )
	{
		my $cp = $self->parameters->{$param}->BuildCommandParam($param_hash)
			if ( defined($self->parameters->{$param} ) );
		# We'll get a empty string for nothing to set, don't add extra space.
		$command_line .= $cp." " if ($cp);
	}

	chop($command_line);
	$self->Verbose("BuildCommandLine: cl($command_line) ",2);
	return ($command_line);
}

1;
#__END__

=back

=head3 INHERITED METHODS

This module is an Object::InsideOut object that inherits from Agent::TCLI::Base. It
inherits methods from both. Please refer to their documentation for more
details.

=head1 AUTHOR

Eric Hacker	 E<lt>hacker at cpan.orgE<gt>

=head1 BUGS

When naming commands in the preinit commands hash or loading from loadyaml()
it is easy to accidentally
duplicate names and cause commands not to load. The author expects that when he
makes this a habit, he'll try to fix it by doing something better than a loading
a hash with no validation.

Most command packages process args in an eval statement which will sometimes
return rather gnarly detailed traces back to the user. This is not a security issue
because open source software is not a black box where such obscurity might
be relied upon (albeit ineffectively), but it is a bug.

SHOULDS and MUSTS are currently not always enforced.

Test scripts not thorough enough.

Probably many others.