1package Workflow::Condition::Evaluate; 2 3use warnings; 4use strict; 5use base qw( Workflow::Condition ); 6use Log::Log4perl qw( get_logger ); 7use Safe; 8use Workflow::Exception qw( condition_error configuration_error ); 9use English qw( -no_match_vars ); 10 11$Workflow::Condition::Evaluate::VERSION = '1.59'; 12 13my @FIELDS = qw( test ); 14__PACKAGE__->mk_accessors(@FIELDS); 15 16# These get put into the safe compartment... 17$Workflow::Condition::Evaluate::context = undef; 18 19sub _init { 20 my ( $self, $params ) = @_; 21 22 $self->test( $params->{test} ); 23 unless ( $self->test ) { 24 configuration_error 25 "The evaluate condition must be configured with 'test'"; 26 } 27 $self->log->info("Added evaluation condition with '$params->{test}'"); 28} 29 30sub evaluate { 31 my ( $self, $wf ) = @_; 32 33 my $to_eval = $self->test; 34 $self->log->info("Evaluating '$to_eval' to see if it returns true..."); 35 36 # Assign our local stuff to package variables... 37 $Workflow::Condition::Evaluate::context = $wf->context->param; 38 39 # Create the Safe compartment and safely eval the test... 40 my $safe = Safe->new(); 41 42 $safe->share('$context'); 43 my $rv = $safe->reval($to_eval); 44 if ($EVAL_ERROR) { 45 condition_error 46 "Condition expressed in code threw exception: $EVAL_ERROR"; 47 } 48 49 $self->log->debug( "Safe eval ran ok, returned: '", 50 ( defined $rv ? $rv : '<undef>' ), 51 "'" ); 52 unless ($rv) { 53 condition_error "Condition expressed by test '$to_eval' did not ", 54 "return a true value."; 55 } 56 return $rv; 57} 58 591; 60 61__END__ 62 63=pod 64 65=head1 NAME 66 67Workflow::Condition::Evaluate - Inline condition that evaluates perl code for truth 68 69=head1 VERSION 70 71This documentation describes version 1.59 of this package 72 73=head1 SYNOPSIS 74 75 <state name="foo"> 76 <action name="foo action"> 77 <condition test="$context->{foo} =~ /^Pita chips$/" /> 78 79=head1 DESCRIPTION 80 81If you've got a simple test you can use Perl code inline instead of 82specifying a condition class. We differentiate by the 'test' attribute 83-- if it's present we assume it's Perl code to be evaluated. 84 85While it's easy to abuse something like this with: 86 87 <condition> 88 <test><![CDATA[ 89 if ( $context->{foo} =~ /^Pita (chips|snacks|bread)$/" ) { 90 return $context->{bar} eq 'hummus'; 91 } 92 else { ... } 93 ]]> 94 </test> 95 </condition> 96 97It should provide a good balance. 98 99=head1 OBJECT METHODS 100 101=head3 new( \%params ) 102 103One of the C<\%params> should be 'test', which contains the text to 104evaluate for truth. 105 106=head3 evaluate( $wf ) 107 108Evaluate the text passed into the constructor: if the evaluation 109returns a true value then the condition passes; if it throws an 110exception or returns a false value, the condition fails. 111 112We use L<Safe> to provide a restricted compartment in which we 113evaluate the text. This should prevent any sneaky bastards from doing 114something like: 115 116 <state...> 117 <action...> 118 <condition test="system( 'rm -rf /' )" /> 119 120The text has access to one variable, for the moment: 121 122=over 4 123 124=item B<$context> 125 126A hashref of all the parameters in the L<Workflow::Context> object 127 128=back 129 130=head1 SEE ALSO 131 132=over 133 134=item * L<Safe> - From some quick research this module seems to have been packaged with core Perl 5.004+, and that's sufficiently ancient for me to not worry about people having it. If this is a problem for you shoot me an email. 135 136=back 137 138=head1 COPYRIGHT 139 140Copyright (c) 2004-2022 Chris Winters. All rights reserved. 141 142This library is free software; you can redistribute it and/or modify 143it under the same terms as Perl itself. 144 145Please see the F<LICENSE> 146 147=head1 AUTHORS 148 149Please see L<Workflow> 150 151=cut 152