From 79db642219e227246eb16f51543cd628408d9a9f Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Tue, 12 May 2009 12:36:26 +0000 Subject: [PATCH] Refactored Survey for more happy endings Refactored www_submitQuestions to use utility submitQuestions sub (for ease of testing) Replaced numeric flags, completedCode etc.. Added restart() and exitUrl() to the Expression Engine Added more Survey instance tests --- lib/WebGUI/Asset/Wobject/Survey.pm | 137 ++++++++---------- .../Asset/Wobject/Survey/ExpressionEngine.pm | 45 +++++- .../Asset/Wobject/Survey/ResponseJSON.pm | 111 +++++++++----- t/Asset/Wobject/Survey.t | 42 +++++- t/Asset/Wobject/Survey/ExpressionEngine.t | 21 ++- t/Asset/Wobject/Survey/ResponseJSON.t | 17 ++- 6 files changed, 255 insertions(+), 118 deletions(-) diff --git a/lib/WebGUI/Asset/Wobject/Survey.pm b/lib/WebGUI/Asset/Wobject/Survey.pm index 04800bab7..bd42b4896 100644 --- a/lib/WebGUI/Asset/Wobject/Survey.pm +++ b/lib/WebGUI/Asset/Wobject/Survey.pm @@ -1415,52 +1415,39 @@ sub www_submitQuestions { my $responses = $self->session->form->paramsHashRef(); delete $responses->{func}; + + return $self->submitQuestions($responses); +} - my @goodResponses = keys %{$responses}; #load everything. +#------------------------------------------------------------------- - my $termInfo = $self->recordResponses( $responses ); +=head2 submitQuestions - if ( $termInfo->[0] ) { +Handles questions submitted by the survey taker, adding them to their response. + +=cut + +sub submitQuestions { + my $self = shift; + my $responses = shift; + + my $result = $self->recordResponses( $responses ); + + # check for special actions + if ( my $url = $result->{terminal} ) { $self->session->log->debug('Terminal, surveyEnd'); - return $self->surveyEnd( $termInfo->[1] ); + return $self->surveyEnd( { exitUrl => $url } ); + } elsif ( exists $result->{exitUrl} ) { + $self->session->log->debug('exitUrl triggered, surveyEnd'); + return $self->surveyEnd( { exitUrl => $result->{exitUrl} }); + } elsif ( my $restart = $result->{restart} ) { + $self->session->log->debug('restart triggered'); + return $self->surveyEnd( { restart => $restart } ); } return $self->www_loadQuestions(); - -# my $files = 0; -# -# for my $id(@$orderOf){ -# if a file upload, write to disk -# my $path; -# if($id->{'questionType'} eq 'File Upload'){ -# $files = 1; -# my $storage = WebGUI::Storage->create($self->session); -# my $filename = $storage->addFileFromFormPost( $id->{'Survey_answerId'} ); -# $path = $storage->getPath($filename); -# } -# $self->session->errorHandler->error("Inserting a response ".$id->{'Survey_answerId'}." $responseId, $path, ".$$responses{$id->{'Survey_answerId'}}); -# $self->session->db->write("insert into Survey_questionResponse -# select ?, Survey_sectionId, Survey_questionId, Survey_answerId, ?, ?, ?, now(), ?, ? from Survey_answer where Survey_answerId = ?", -# [$self->getId(), $responseId, $$responses{ $id->{'Survey_answerId'} }, '', $path, ++$lastOrder, $id->{'Survey_answerId'}]); -# } -# if ($files) { -# ##special case, need to check for more questions in section, if not, more current up one -# my $lastA = $self->getLastAnswerInfo($responseId); -# my $questionId = $self->getNextQuestionId( $lastA->{'Survey_questionId'} ); -# if ( !$questionId ) { -# my $currentSection = $self->getCurrentSection($responseId); -# $currentSection = $self->getNextSection($currentSection); -# if ($currentSection) { -# $self->setCurrentSection( $responseId, $currentSection ); -# } -# } -# return; -# } -# return $self->www_loadQuestions($responseId); - } - #------------------------------------------------------------------- =head2 www_goBack @@ -1536,7 +1523,7 @@ sub www_loadQuestions { } if ( $self->responseJSON->hasTimedOut( $self->get('timeLimit') ) ) { $self->session->log->debug('Response hasTimedOut, surveyEnd'); - return $self->surveyEnd( undef, 2 ); + return $self->surveyEnd( { timeout => 1 } ); } if ( $self->responseJSON->surveyEnd() ) { @@ -1568,37 +1555,51 @@ sub www_loadQuestions { #------------------------------------------------------------------- -=head2 surveyEnd ( [ $url ], [ $completeCode ] ) +=head2 surveyEnd ( [ $options ] ) -Marks the survey completed with either 1 or the $completeCode and then sends the url to the site home or if defined, $url. +Marks the survey response as completed and carries out special actions such as restarting or exiting to an exitUrl -=head3 $url +=head3 $options -An optional url to send the user to upon survey completion. +The following options are supported -=head3 $completeCode +=over3 -An optional code (defaults to 1) to say how the user completed the survey. +=item timeout -1 is normal completion. -2 is timed out. +Indicates that the survey has timed out. The doAfterTimeLimit setting controls whether the +survey restarts or exits to the exitUrl. + +=item restart + +The survey should be restarted + +=item exitUrl + +Exit to the supplied url, or if no url is provided exit to the survey's exitUrl. =cut sub surveyEnd { - my $self = shift; - my $url = shift; - my $completeCode = shift; - - $completeCode = defined $completeCode ? $completeCode : 1; - + my $self = shift; + my %opts = validate(@_, { timeout => 0, restart => 0, exitUrl => 0 }); + + # See if we should restart the Survey instead of completing it + if ( $opts{restart} || ( $opts{timeout} && $self->get('doAfterTimeLimit') eq 'restartSurvey' ) ){ + $self->responseJSON->resetResponse(); + $self->persistResponseJSON; + delete $self->{responseId}; + return $self->www_loadQuestions('1'); + } + + # If an in-progress response exists, mark it as complete if ( my $responseId = $self->responseId ) { $self->session->db->setRow( 'Survey_response', 'Survey_responseId', { Survey_responseId => $responseId, - endDate => scalar time, #WebGUI::DateTime->now->toDatabase, - isComplete => $completeCode + endDate => scalar time, + isComplete => 1, } ); @@ -1614,26 +1615,16 @@ sub surveyEnd { } )->start; } - } - if ($self->get('doAfterTimeLimit') eq 'restartSurvey' && $completeCode == 2){ - $self->responseJSON->startTime(scalar time); - undef $self->{_responseJSON}; - undef $self->{responseId}; - return $self->www_loadQuestions('1'); - } else { - if ( $url !~ /\w/ ) { $url = 0; } - if ( $url eq 'undefined' ) { $url = 0; } - if ( !$url ) { - $url = $self->get('exitURL'); - if ( !$url ) { - $url = q{/}; - } - } } - $url = $self->session->url->gateway($url) if($url !~ /^http:/i); - #$self->session->http->setRedirect($url); - #$self->session->http->setMimeType('application/json'); - my $json = to_json( { type => 'forward', url => $url } ); + + + # If we get this far, it's time to forward users to an exitUrl + my $exitUrl = $opts{exitUrl}; + undef $exitUrl if $exitUrl !~ /\w/; + undef $exitUrl if $exitUrl eq 'undefined'; + $exitUrl = $exitUrl || $self->get('exitURL') || q{/}; + $exitUrl = $self->session->url->gateway($exitUrl) if($exitUrl !~ /^https?:/i); + my $json = to_json( { type => 'forward', url => $exitUrl } ); $self->session->http->setMimeType('application/json'); return $json; } diff --git a/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm b/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm index 71924730f..ca56456b0 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm @@ -309,6 +309,35 @@ sub jump(&$) { } } +=head2 exitUrl ( [$url] ) + +Same as L except that instead of a jump, triggers survey exit + +=head3 url (optional) + +Url to exit to. If not given, the Survey instance's exitUrl property will be used. + +=cut + +sub exitUrl { + my ( $url ) = @_; + + $session->log->debug("exitUrl($url)"); + die( { exitUrl => $url } ); +} + + +=head2 restart ( $sub ) + +Same as L except that instead of a jump, triggers the Survey to restart + +=cut + +sub restart { + $session->log->debug("restart()"); + die( { restart => 1 } ); +} + =head2 avg Utility sub shared with Safe compartment to allows expressions to easily compute the average of a list @@ -419,6 +448,8 @@ sub run { $compartment->share('&tagged'); $compartment->share('&taggedX'); $compartment->share('&jump'); + $compartment->share('&exitUrl'); + $compartment->share('&restart'); $compartment->share('&avg'); # Give them all of List::Util too @@ -440,10 +471,16 @@ sub run { } # A successful jump triggers a hashref containing the jump target to be thrown - if ( ref $@ && ref $@ eq 'HASH' && $@->{jump} ) { - my $jump = $@->{jump}; - $session->log->debug("Returning [$jump]"); - return { jump => $jump, tags => $tags }; + if ( ref $@ && ref $@ eq 'HASH') { + if (my $target = $@->{jump}) { + return { jump => $target, tags => $tags }; + } + if (exists $@->{exitUrl}) { # url might be undefined + return { exitUrl => $@->{exitUrl}, tags => $tags }; + } + if (my $restart = $@->{restart}) { + return { restart => $restart, tags => $tags }; + } } # See if an unresolved external reference was encountered diff --git a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm index 61e96d8a1..cac14a5cd 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm @@ -79,24 +79,14 @@ sub new { # First define core members.. _survey => $survey, _session => $survey->session, - - # Store all properties that are (de)serialized to/from JSON in a private variable - _response => { - - # Response hash defaults.. - responses => {}, - lastResponse => -1, - questionsAnswered => 0, - startTime => time(), - surveyOrder => undef, - tags => {}, - - # And then allow jsonData to override defaults and/or add other members - %{$jsonData}, - }, }; - return bless $self, $class; + bless $self, $class; + + # Initialise response data + $self->resetResponse($jsonData); + + return $self; } #---------------------------------------------------------------------------- @@ -508,7 +498,7 @@ sub recordResponses { if ( !@questions and !$section->{logical}) { # No questions to process, so increment lastResponse and return $self->lastResponse( $self->nextResponse ); - return [ $sTerminal, $terminalUrl ]; + return $sTerminal ? { terminal => $terminalUrl} : {}; } # Process Questions in Section.. @@ -612,13 +602,22 @@ sub recordResponses { # Process jumps and jump expressions in precedence order of: # answer goto, answer expression, question goto, question expression, section.. - $self->processGoto($answerGoto) if defined $answerGoto; ## no critic - $self->processExpression($answerExpression) if defined $answerExpression; ## no critic - $self->processGoto($questionGoto) if defined $questionGoto; ## no critic - $self->processExpression($questionExpression) if defined $questionExpression; ## no critic - $self->processGoto($sectionGoto) if defined $sectionGoto; ## no critic - $self->processExpression($sectionExpression) if defined $sectionExpression; ## no critic - + + # The joined logical OR here carries out the short-circuting for us + # e.g. processGoto returns 1 on its first match + # and processExpression returns hashref on its first match + my $action = $self->processGoto($answerGoto) || + $self->processExpression($answerExpression) || + $self->processGoto($questionGoto) || + $self->processExpression($questionExpression) || + $self->processGoto($sectionGoto) || + $self->processExpression($sectionExpression); + + # Special actions (such as exitUrl and restart) happen straight away + if ($action && ref $action eq 'HASH') { + return $action; + } + # Handle next logic Section.. my $section = $self->nextResponseSection(); if ( $section and $section->{logical} ) { @@ -634,7 +633,10 @@ sub recordResponses { $terminal = 1; } - return [ $terminal, $terminalUrl ]; + if ($terminal) { + return { terminal => $terminalUrl }; + } + return {}; } #------------------------------------------------------------------- @@ -653,7 +655,9 @@ A variable name to match against all section and question variable names. sub processGoto { my $self = shift; - my ($goto) = validate_pos(@_, {type => SCALAR}); + my ($goto) = validate_pos(@_, {type => SCALAR|UNDEF}); + + return if !$goto; if ($goto eq 'NEXT_SECTION') { $self->session->log->debug("NEXT_SECTION jump target encountered"); @@ -663,13 +667,13 @@ sub processGoto { while ($self->nextResponseSectionIndex == $lastResponseSectionIndex) { $self->lastResponse( $self->lastResponse + 1); } - return; + return 1; } if ($goto eq 'END_SURVEY') { $self->session->log->debug("END_SURVEY jump target encountered"); $self->lastResponse( scalar( @{ $self->surveyOrder} ) - 1 ); - return; + return 1; } # Iterate over items in order.. @@ -685,7 +689,7 @@ sub processGoto { # Fudge lastResponse so that the next response item will be our matching item $self->lastResponse( $itemIndex - 1 ); - last; + return 1; } # See if our goto variable matches the question variable.. @@ -693,7 +697,7 @@ sub processGoto { # Fudge lastResponse so that the next response item will be our matching item $self->lastResponse( $itemIndex - 1 ); - last; + return 1; } # Increment the item index counter @@ -720,7 +724,9 @@ The expression. See L for mor sub processExpression { my $self = shift; - my ($expression) = validate_pos(@_, {type => SCALAR}); + my ($expression) = validate_pos(@_, {type => SCALAR|UNDEF}); + + return if !$expression; # Prepare the ingredients.. my $values = $self->responseValuesByVariableName; @@ -738,11 +744,19 @@ sub processExpression { if (my $jump = $result->{jump}) { $self->session->log->debug("Jumping to [$jump]"); - $self->processGoto($jump); + return $self->processGoto($jump); + } elsif (exists $result->{exitUrl}) { # may be undefined + my $exitUrl = $result->{exitUrl}; + $self->session->log->debug("exitUrl triggered [$exitUrl]"); + return { exitUrl => $exitUrl }; + } elsif (my $restart = $result->{restart}) { + $self->session->log->debug("restart triggered"); + return { restart => $restart }; } else { $self->session->log->debug("No hits, falling through"); + return; } - } + } return; } @@ -1349,6 +1363,37 @@ sub returnResponseForReporting { #------------------------------------------------------------------- +=head2 resetResponse ( [$data] ) + +Resets all response data (e.g. for when you want to restart a survey) + +=head3 data (optional) + +Extra data to apply over the defaults + +=cut + +sub resetResponse { + my $self = shift; + my $data = shift || {}; + + $self->{_response} = { + + # Response hash defaults.. + responses => {}, + lastResponse => -1, + questionsAnswered => 0, + startTime => time(), + surveyOrder => undef, + tags => {}, + + # And then allow overrides + %{$data}, + }; +} + +#------------------------------------------------------------------- + =head2 response Accessor for the Perl hash containing Response data diff --git a/t/Asset/Wobject/Survey.t b/t/Asset/Wobject/Survey.t index 995ba2fd7..220a35899 100644 --- a/t/Asset/Wobject/Survey.t +++ b/t/Asset/Wobject/Survey.t @@ -18,7 +18,7 @@ my $session = WebGUI::Test->session; #---------------------------------------------------------------------------- # Tests -my $tests = 20; +my $tests = 24; plan tests => $tests + 1; #---------------------------------------------------------------------------- @@ -90,6 +90,46 @@ delete $s->{responseId}; ok($s->canTakeSurvey, '..and also when maxResponsesPerUser set to 0 (unlimited)'); ok($s->responseId, '..(and similarly for responseId)'); +# Restart the survey +$s->submitQuestions({ + '0-0-0' => 'My chosen answer', + '0-1-0' => 'My chosen answer', +}); + +cmp_deeply( + $s->responseJSON->responses, + superhashof( + { '0-1-0' => { + 'verbatim' => undef, + 'comment' => undef, + 'time' => num( time, 5 ), + 'value' => '' + }, + '0-0-0' => { + 'verbatim' => undef, + 'comment' => undef, + 'time' => num( time, 5 ), + 'value' => '' + }, + } + ), + 'submitQuestions does the right thing' +); + +# Test out Restart +$s->surveyEnd( { restart => 1 } ); +cmp_deeply($s->responseJSON->responses, {}, 'restart removes the in-progress response'); + +# Test out exitUrl with an explicit +use JSON; +my $surveyEnd = $s->surveyEnd( { exitUrl => 'home' } ); +cmp_deeply(from_json($surveyEnd), { type => 'forward', url => '/home' }, 'exitUrl works (it adds a slash for us)'); + +# Test out exitUrl using survye instance exitURL property +$s->update({ exitURL => 'getting_started'}); +$surveyEnd = $s->surveyEnd( { exitUrl => undef } ); +cmp_deeply(from_json($surveyEnd), { type => 'forward', url => '/getting_started' }, 'exitUrl works (it adds a slash for us)'); + # www_jumpTo { # Check a simple www_jumpTo request diff --git a/t/Asset/Wobject/Survey/ExpressionEngine.t b/t/Asset/Wobject/Survey/ExpressionEngine.t index b4881c5c3..b2fd409e3 100644 --- a/t/Asset/Wobject/Survey/ExpressionEngine.t +++ b/t/Asset/Wobject/Survey/ExpressionEngine.t @@ -22,7 +22,7 @@ my $session = WebGUI::Test->session; #---------------------------------------------------------------------------- # Tests -my $tests = 52; +my $tests = 55; plan tests => $tests + 1; #---------------------------------------------------------------------------- @@ -163,6 +163,25 @@ SKIP: { { jump => 'target', tags => { a => 'xyz' } }, '..overwritten tag data can be used too' ); + + # Try the exitUrl sub + cmp_deeply( + $e->run( $session, q{ exitUrl(blah)} ), + { exitUrl => 'blah', tags => { } }, + 'explicit exitUrl works' + ); + cmp_deeply( + $e->run( $session, q{ exitUrl()} ), + { exitUrl => undef, tags => { } }, + '..as does unspecified exitUrl' + ); + + # Try the restart sub + cmp_deeply( + $e->run( $session, q{ restart} ), + { restart => 1, tags => { } }, + 'restart works' + ); # Create a test user $user = WebGUI::User->new( $session, 'new' ); diff --git a/t/Asset/Wobject/Survey/ResponseJSON.t b/t/Asset/Wobject/Survey/ResponseJSON.t index 94e52ee60..7345c1f32 100644 --- a/t/Asset/Wobject/Survey/ResponseJSON.t +++ b/t/Asset/Wobject/Survey/ResponseJSON.t @@ -22,7 +22,7 @@ my $session = WebGUI::Test->session; #---------------------------------------------------------------------------- # Tests -my $tests = 93; +my $tests = 96; plan tests => $tests + 1; #---------------------------------------------------------------------------- @@ -484,6 +484,11 @@ $rJSON->nextResponse(2); # pretend we just finished s0q2 $rJSON->processExpression(q{jump { (value(s0q2_verbatim))[0] eq 'YesYesYes' && (value(s0q2_verbatim))[1] eq 'NoNoNo' } s2}); is($rJSON->nextResponse, 5, '..and we can get list of verbatims too'); +$rJSON->nextResponse(2); # pretend we just finished s0q2 +cmp_deeply($rJSON->processExpression(q{restart()}), { restart => 1 }, 'restart works'); +cmp_deeply($rJSON->processExpression(q{exitUrl(blah)}), { exitUrl => 'blah' }, 'explicit exitUrl works'); +cmp_deeply($rJSON->processExpression(q{exitUrl()}), { exitUrl => undef }, 'unspecified exitUrl works too'); + # Clean up after this set of tests $rJSON->responses({}); $rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered); @@ -499,8 +504,8 @@ $rJSON->lastResponse(4); my $terminals; cmp_deeply( $rJSON->recordResponses({}), - [ 0, undef ], - 'recordResponses, if section has no questions, returns terminal info in the section. With no terminal info, returns [0, undef]', + {}, + 'recordResponses, if section has no questions, returns terminal info in the section. With no terminal info, returns {}', ); is($rJSON->lastResponse(), 5, 'recordResponses, increments lastResponse if there are no questions in the section'); @@ -510,7 +515,7 @@ $rJSON->survey->section([2])->{terminalUrl} = '/terminal'; $rJSON->lastResponse(4); cmp_deeply( $rJSON->recordResponses({}), - [ 1, '/terminal' ], + { terminal => '/terminal' }, 'recordResponses, if section has no questions, returns terminal info in the section.', ); is($rJSON->questionsAnswered, 0, 'questionsAnswered=0, no questions answered'); @@ -527,7 +532,7 @@ cmp_deeply( '1-0-0verbatim' => 'First answer verbatim', # ignored '1-0-0comment' => 'Section 1, question 0, answer 0 comment', }), - [ 1, 'question 1-0 terminal' ], + { terminal => 'question 1-0 terminal' }, 'recordResponses: question terminal overrides section terminal', ); @@ -627,7 +632,7 @@ cmp_deeply( '1-0-0' => "\t\t\t\n\n\n\t\t\t", #SOS in whitespace '1-0-0comment' => 'Section 1, question 0, answer 0 comment', }), - [ 1, 'answer 1-0-0 terminal' ], + { terminal => 'answer 1-0-0 terminal'}, 'recordResponses: answer terminal overrides question and section terminals', );