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