oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Started refactoring nextQuestions in ResponseJSON

Browse source 
Made perlcritic happier
Extracted getQuestionResponses from processGotoExpression
Eliminated getPreviousAnswer
This commit is contained in:
Patrick Donelan 2009-02-06 01:56:54 +00:00
parent 3340a675b7
commit 306502465c
2 changed files with 115 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

179
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
View file

@ -570,8 +570,8 @@ sub recordResponses {
$self->lastResponse( $self->lastResponse + @questions ); $self->lastResponse( $self->lastResponse + @questions );
# Do any requested branching.. # Do any requested branching..
$self->processGoto($goto) if ( defined $goto ); $self->processGoto($goto) if ( defined $goto ); ## no critic
$self->processGotoExpression($gotoExpression) if ( defined $gotoExpression ); $self->processGotoExpression($gotoExpression) if ( defined $gotoExpression ); ## no critic
} }
else { else {
# Required responses were missing, so we don't let the Survey terminate # Required responses were missing, so we don't let the Survey terminate
@ -637,85 +637,122 @@ sub processGoto {
=head2 processGotoExpression ( $gotoExpression ) =head2 processGotoExpression ( $gotoExpression )
Processes the given gotoExpression, and triggers a call to L<"processGoto"> if the expression
indicates that we should branch.
=head3 $gotoExpression =head3 $gotoExpression
The gotoExpression (one expression per line) The gotoExpression.
=head3 Explanation A gotoExpression is a string representing a list of expressions (one per line) of the form:
A gotoExpression is a list of expressions (one per line) of the form:
target: expression target: expression
target: expression target: expression
...
This subroutine iterates through the list, processing each line and, all things being This subroutine iterates through the list, processing each line and, all things being
well, evaluates the expression. The first expression to evaluate to true triggers a well, evaluates the expression. The first expression to evaluate to true triggers a
call to goto($target). call to goto($target).
The expression is a simple subset of the formula language used in spreadsheet programs such as Excel, OpenOffice, Google Docs etc.. The expression is a simple subset of the formula language used in spreadsheet programs
such as Excel, OpenOffice, Google Docs etc..
Here is an example using section variables S1 and S2 as jump targets and question variables Q1-3 in the expression. Here is an example using section variables S1 and S2 as jump targets and question
It jumps to S1 if the user's answer to Q1 has a value of 3, jumps to S2 if Q2 + Q3 < 10, and otherwise doesn't branch at all (the default). variables Q1-3 in the expression. It jumps to S1 if the user's answer to Q1 has a value
of 3, jumps to S2 if Q2 + Q3 < 10, and otherwise doesn't branch at all (the default).
S1: Q1 = 3 S1: Q1 = 3
S2: Q2 + Q3 < 10 S2: Q2 + Q3 < 10
=head3 Arguments are evaluated as follows: Arguments are evaluated as follows:
Numeric arguments evaluate as numbers Numeric arguments evaluate as numbers
* No support for strings (and hence no string matching)
* Question variable names (e.g. Q1) evaluate to the numeric value associated with user's answer to that question, or undefined if the user has not answered that question =over 4
=item * No support for strings (and hence no string matching)
=item * Question variable names (e.g. Q1) evaluate to the numeric value associated with
user's answer to that question, or undefined if the user has not answered that question
=back
Binary comparisons operators: = != < <= >= > Binary comparisons operators: = != < <= >= >
* return boolean values based on perl's equivalent numeric comparison operators
=over 4
=item * return boolean values based on perl's equivalent numeric comparison operators
=back
Simple math operators: + - * / Simple math operators: + - * /
* return numeric values
Later we may add Boolean operators: AND( x; y; z; ... ), OR( x; y; z; ... ), NOT( x ) =over 4
* args separated by semicolons (presumably because spreadsheet formulas use commas to indicate cell ranges)
Later still you may be able to say AVG(section1) or SUM(section3) and have those functions automatically compute their result over the set of all questions in the given section. =item * return numeric values
=back
Later we may add Boolean operators: AND( x; y; z; ... ), OR( x; y; z; ... ), NOT( x ), with args separated by
semicolons (presumably because spreadsheet formulas use commas to indicate cell ranges)
Later still you may be able to say AVG(section1) or SUM(section3) and have those functions automatically
compute their result over the set of all questions in the given section.
But for now those things can be done manually using the limited subset defined. But for now those things can be done manually using the limited subset defined.
=cut =cut
sub processGotoExpression { sub processGotoExpression {
my $self = shift; my $self = shift;
my $expression = shift; my ($expression) = validate_pos(@_, {type => SCALAR});
my %responses = ( my $responses = $self->getQuestionResponses();
# questionName => response answer value
);
# Populate %responses with the user's data..
foreach my $q (@{ $self->returnResponseForReporting() }) {
if ($q->{questionName} =~ /\w/) {
my $value = $q->{answers}[0]{value};
$responses{$q->{questionName}} = $value if defined $value;
}
}
# Parse gotoExpressions one after the other (first one that's true wins) # Parse gotoExpressions one after the other (first one that's true wins)
foreach my $line (split '\n', $expression) { foreach my $line (split /\n/, $expression) {
my $processed = $self->parseGotoExpression($line, \%responses); my $processed = $self->parseGotoExpression($line, $responses);
next unless $processed; next if !$processed;
# (ab)use perl's eval to evaluate the processed expression # (ab)use perl's eval to evaluate the processed expression
my $result = eval "$processed->{expression}"; my $result = eval "$processed->{expression}"; ## no critic
$self->session->log->warn($@) if $@; $self->session->log->warn($@) if $@; ## no critic
if ($result) { if ($result) {
$self->session->log->debug("Truthy, goto [$processed->{target}]"); $self->session->log->debug("Truthy, goto [$processed->{target}]");
$self->processGoto($processed->{target}); $self->processGoto($processed->{target});
return $processed; return $processed;
} else { } else {
$self->session->log->debug("Falsy, not branching"); $self->session->log->debug('Falsy, not branching');
next; next;
} }
} }
return; return;
} }
sub getQuestionResponses {
my $self = shift;
my $responses= {
# questionName => response answer value
};
# Populate %responses with the user's data..
for my $address ( @{ $self->surveyOrder } ) {
my $question = $self->survey->question( $address );
my $sIndex = $address->[0];
my $qIndex = $address->[1];
for my $aIndex (@{ $address->[2] }) {
if ( defined $self->responses->{"$sIndex-$qIndex-$aIndex"} ) {
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
$responses->{$question->{variable}}
= $answer->{value} =~ /\w/ ? $answer->{value}
: $question->{value}
;
}
}
}
return $responses;
}
=head2 parseGotoExpression( ( $expression, $responses) =head2 parseGotoExpression( ( $expression, $responses)
Parses a single gotoExpression. Returns undef if processing fails, or the following hashref Parses a single gotoExpression. Returns undef if processing fails, or the following hashref
@ -748,8 +785,7 @@ the expression generate an error because our list of valid tokens doesn't includ
sub parseGotoExpression { sub parseGotoExpression {
my $self = shift; my $self = shift;
my $expression = shift; my ($expression, $responses) = validate_pos(@_, { type => SCALAR }, { type => HASHREF, default => {} });
my $responses = shift;
$self->session->log->debug("Parsing gotoExpression: $expression"); $self->session->log->debug("Parsing gotoExpression: $expression");
@ -765,13 +801,13 @@ sub parseGotoExpression {
return; return;
} }
if ( !defined $rest || $rest eq '' ) { if ( !defined $rest || $rest eq q{} ) {
$self->session->log->warn('Expression undefined'); $self->session->log->warn('Expression undefined');
return; return;
} }
# Replace each questionName with its response value # Replace each questionName with its response value
while ( my ( $questionName, $response ) = each %$responses ) { while ( my ( $questionName, $response ) = each %{$responses} ) {
$rest =~ s/$questionName/$response/g; $rest =~ s/$questionName/$response/g;
} }
@ -791,26 +827,32 @@ sub parseGotoExpression {
}; };
} }
#------------------------------------------------------------------- # This method is unnecessary, as it can be expressed as:
# $self->getQuestionResponses()->{$questionParam};
=head2 getPreviousAnswer #
#=head2 getPreviousAnswer
=cut #
#=cut
sub getPreviousAnswer { #
my $self = shift; #sub getPreviousAnswer {
my $questionParam = shift; # my $self = shift;
for my $q ( @{ $self->surveyOrder } ) { # my $questionParam = shift;
my $question = $self->survey->question( [ $$q[0], $$q[1] ] ); #
if ( $question->{variable} eq $questionParam ) { # for my $address ( @{ $self->surveyOrder } ) {
for ( 0 .. @{ $self->survey->answers( [ $$q[0], $$q[1] ] ) } ) { # my $question = $self->survey->question( $address );
if ( exists $self->responses->{ $$q[0] . "-" . $$q[1] . "-" . $_ } ) { # if ( $question->{variable} eq $questionParam ) {
return $self->responses->{ $$q[0] . "-" . $$q[1] . "-" . $_ }->{value}; #
} # # Iterate over answers in the question..
} # for ( 0 .. @{ $self->survey->answers( $address ) } ) {
} # use Data::Dumper;
} # $self->session->log->warn(Dumper($_));
} # if ( exists $self->responses->{ $address->[0] . "-" . $address->[1] . "-" . $_ } ) {
# return $self->responses->{ $address->[0] . "-" . $address->[1] . "-" . $_ }->{value};
# }
# }
# }
# }
#}
#------------------------------------------------------------------- #-------------------------------------------------------------------
@ -838,31 +880,30 @@ sub nextQuestions {
return if $self->surveyEnd; return if $self->surveyEnd;
my $nextResponseSectionIndex = $self->nextResponseSectionIndex;
my $qPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage};
#load Previous answer text
my $section = $self->nextResponseSection(); my $section = $self->nextResponseSection();
$section->{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg; my $sectionIndex = $self->nextResponseSectionIndex;
my $questionsPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage};
my $questionResponses = $self->getQuestionResponses();
$section->{'text'} =~ s/\[\[([^\%]*?)\]\]/$questionResponses->{$1}/eg;
my @questions; my @questions;
for ( my $i = 1; $i <= $qPerPage; $i++ ) { for my $i (1 .. $questionsPerPage ) {
my $qAddy = $self->surveyOrder->[ $self->lastResponse + $i ]; my $qAddy = $self->surveyOrder->[ $self->lastResponse + $i ];
next next
if ( !exists $$qAddy[1] ); #skip this if it doesn't have a question (for sections with no questions) if ( !exists $$qAddy[1] ); #skip this if it doesn't have a question (for sections with no questions)
if ( $$qAddy[0] != $nextResponseSectionIndex ) { if ( $$qAddy[0] != $sectionIndex ) {
last; last;
} }
my %question = %{ $self->survey->question( [ $$qAddy[0], $$qAddy[1] ] ) }; my %question = %{ $self->survey->question( [ $$qAddy[0], $$qAddy[1] ] ) };
$question{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg; $question{'text'} =~ s/\[\[([^\%]*?)\]\]/$questionResponses->{$1}/eg;
delete $question{answers}; delete $question{answers};
$question{id} = "$$qAddy[0]-$$qAddy[1]"; $question{id} = "$$qAddy[0]-$$qAddy[1]";
$question{sid} = "$$qAddy[0]"; $question{sid} = "$$qAddy[0]";
for ( @{ $$qAddy[2] } ) { for ( @{ $$qAddy[2] } ) {
my %ans = %{ $self->survey->answer( [ $$qAddy[0], $$qAddy[1], $_ ] ) }; my %ans = %{ $self->survey->answer( [ $$qAddy[0], $$qAddy[1], $_ ] ) };
$ans{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg; $ans{'text'} =~ s/\[\[([^\%]*?)\]\]/$questionResponses->{$1}/eg;
$ans{id} = "$$qAddy[0]-$$qAddy[1]-$_"; $ans{id} = "$$qAddy[0]-$$qAddy[1]-$_";
push( @{ $question{answers} }, \%ans ); push( @{ $question{answers} }, \%ans );
} }

8
t/Asset/Wobject/Survey/ResponseJSON.t
View file

@ -9,6 +9,7 @@ use lib "$FindBin::Bin/../../../lib";
use Test::More; use Test::More;
use Test::Deep; use Test::Deep;
use Test::MockObject::Extends; use Test::MockObject::Extends;
use Test::Exception;
use Data::Dumper; use Data::Dumper;
use WebGUI::Test; # Must use this before any other WebGUI modules use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session; use WebGUI::Session;
@ -20,7 +21,7 @@ my $session = WebGUI::Test->session;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# Tests # Tests
my $tests = 78; my $tests = 79;
plan tests => $tests + 1; plan tests => $tests + 1;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
@ -321,8 +322,9 @@ is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
# processGotoExpression # processGotoExpression
# #
#################################################### ####################################################
is($rJSON->parseGotoExpression(), throws_ok { $rJSON->parseGotoExpression() } 'WebGUI::Error::InvalidParam', 'processGotoExpression takes exception to empty arguments';
undef, 'processGotoExpression undef with empty arguments'); is($rJSON->parseGotoExpression(q{}),
undef, '.. and undef with empty expression');
is($rJSON->parseGotoExpression('blah-dee-blah-blah'), is($rJSON->parseGotoExpression('blah-dee-blah-blah'),
undef, '.. and undef with duff expression'); undef, '.. and undef with duff expression');
is($rJSON->parseGotoExpression(':'), is($rJSON->parseGotoExpression(':'),