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

More SurveyJSON refactoring..

Browse source
This commit is contained in:
Patrick Donelan 2009-01-21 05:34:41 +00:00
parent ef7c0cfaa1
commit 102ec0dd25
1 changed files with 192 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

280
lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm
View file

@ -54,6 +54,9 @@ use JSON;
#use Clone qw/clone/; #use Clone qw/clone/;
use Storable qw/dclone/; use Storable qw/dclone/;
# The maximum value of questionsPerPage is currently hardcoded here
my $MAX_QUESTIONS_PER_PAGE = 20;
=head2 new ( $json, $log ) =head2 new ( $json, $log )
Object constructor. Object constructor.
@ -92,7 +95,7 @@ sub new {
bless( $self, $class ); bless( $self, $class );
# Initialise the survey data structure if empty.. # Initialise the survey data structure if empty..
if ( @{ $self->sections } == 0 ) { if ( $self->totalSections == 0 ) {
$self->newObject( [] ); $self->newObject( [] );
} }
return $self; return $self;
@ -157,21 +160,21 @@ sub newObject {
push( @{ $self->sections }, $self->newSection() ); push( @{ $self->sections }, $self->newSection() );
# Update $address with the index of the newly created section # Update $address with the index of the newly created section
$address->[0] = $#{ $self->sections }; $address->[0] = $self->totalSections - 1;
} }
elsif ( $count == 1 ) { elsif ( $count == 1 ) {
# Add a new question to the end of the list of questions in section located at $address # Add a new question to the end of the list of questions in section located at $address
push( @{ $self->questions($address) }, $self->newQuestion($address) ); push( @{ $self->questions($address) }, $self->newQuestion($address) );
# Update $address with the index of the newly created question # Update $address with the index of the newly created question
$address->[1] = $#{ $self->questions($address) }; $address->[1] = $self->totalQuestions($address) - 1;
} }
elsif ( $count == 2 ) { elsif ( $count == 2 ) {
# Add a new answer to the end of the list of answers in section/question located at $address # Add a new answer to the end of the list of answers in section/question located at $address
push( @{ $self->answers($address) }, $self->newAnswer($address) ); push( @{ $self->answers($address) }, $self->newAnswer($address) );
# Update $address with the index of the newly created answer # Update $address with the index of the newly created answer
$address->[2] = $#{ $self->answers($address) }; $address->[2] = $self->totalAnswers($address) - 1;
} }
return $address; return $address;
} }
@ -220,7 +223,7 @@ sub getDragDropList {
my @data; my @data;
for ( my $sIndex = 0; $sIndex < $self->totalSections; $sIndex++ ) { for ( my $sIndex = 0; $sIndex < $self->totalSections; $sIndex++ ) {
push( @data, { text => $self->section( [$sIndex] )->{title}, type => 'section' } ); push( @data, { text => $self->section( [$sIndex] )->{title}, type => 'section' } );
if ( $address->[0] == $sIndex ) { if ( sIndex($address) == $sIndex ) {
for ( my $qIndex = 0; $qIndex < $self->totalQuestions($address); $qIndex++ ) { for ( my $qIndex = 0; $qIndex < $self->totalQuestions($address); $qIndex++ ) {
push( push(
@ -229,7 +232,7 @@ sub getDragDropList {
type => 'question' type => 'question'
} }
); );
if ( $address->[1] == $qIndex ) { if ( qIndex($address) == $qIndex ) {
for ( my $aIndex = 0; $aIndex < $self->totalAnswers($address); $aIndex++ ) { for ( my $aIndex = 0; $aIndex < $self->totalAnswers($address); $aIndex++ ) {
push( push(
@data, @data,
@ -287,14 +290,14 @@ sub getObject {
return unless $count; return unless $count;
if ( $count == 1 ) { if ( $count == 1 ) {
return dclone $self->{sections}->[ $address->[0] ]; return dclone $self->{sections}->[ sIndex($address) ];
} }
elsif ( $count == 2 ) { elsif ( $count == 2 ) {
return dclone $self->{sections}->[ $address->[0] ]->{questions}->[ $address->[1] ]; return dclone $self->{sections}->[ sIndex($address) ]->{questions}->[ qIndex($address) ];
} }
else { else {
return dclone $self->{sections}->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers} return dclone $self->{sections}->[ sIndex($address) ]->{questions}->[ qIndex($address) ]->{answers}
->[ $address->[2] ]; ->[ aIndex($address) ];
} }
} }
@ -314,23 +317,57 @@ sections, questions, or answers.
sub getEditVars { sub getEditVars {
my ( $self, $address ) = @_; my ( $self, $address ) = @_;
if ( @$address == 1 ) { # Figure out what to do by counting the number of elements in the $address array ref
my $count = @$address;
if ( $count == 1 ) {
return $self->getSectionEditVars($address); return $self->getSectionEditVars($address);
} }
elsif ( @$address == 2 ) { elsif ( $count == 2 ) {
return $self->getQuestionEditVars($address); return $self->getQuestionEditVars($address);
} }
elsif ( @$address == 3 ) { elsif ( $count == 3 ) {
return $self->getAnswerEditVars($address); return $self->getAnswerEditVars($address);
} }
} }
=head2 getGotoTargets
Generates the list of valid goto targets
=cut
sub getGotoTargets {
my $self = shift;
# Valid goto targets are all of the section variable names..
my @section_vars = map {$_->{variable}} @{$self->sections};
# ..and all of the question variable names..
my @question_vars = map {$_->{variable}} @{$self->questions};
# ..excluding the ones that are empty
return grep {$_ ne ''} (@section_vars, @question_vars);
}
=head2 getSectionEditVars ( $address ) =head2 getSectionEditVars ( $address )
Get a safe copy of the variables for this section, to use for editing Get a safe copy of the variables for this section, to use for editing
purposes. Adds two variables, id, which is the index of this section, purposes.
and displayed_id, which is this question's index in a 1-based array
(versus the default, perl style, 0-based array). Adds two variables:
=over 4
=item * id
the index of this section
=item * displayed_id
this question's index in a 1-based array (versus the default, perl style, 0-based array)
=back
It removes the questions array ref, and changes questionsPerPage from a single element, into It removes the questions array ref, and changes questionsPerPage from a single element, into
an array of hashrefs, which list the available questions per page and which one is currently an array of hashrefs, which list the available questions per page and which one is currently
@ -345,40 +382,47 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
sub getSectionEditVars { sub getSectionEditVars {
my $self = shift; my $self = shift;
my $address = shift; my $address = shift;
my $object = $self->section($address); my $section = $self->section($address);
my %var = %{$object}; my %var = %{$section};
$var{id} = $address->[0];
$var{displayed_id} = $address->[0] + 1; # Add the extra fields..
$var{id} = sIndex($address);
$var{displayed_id} = sIndex($address) + 1;
# Remove the fields we don't want..
delete $var{questions}; delete $var{questions};
delete $var{questionsPerPage}; delete $var{questionsPerPage};
for ( 1 .. 20 ) { # Change questionsPerPage from a single element, into an array of hashrefs, which list the
# available questions per page and which one is currently selected for this section..
# if($_ == $self->section($address)->{questionsPerPage}){ for my $index ( 1 .. $MAX_QUESTIONS_PER_PAGE ) {
if ( $_ == $object->{questionsPerPage} ) { if ( $index == $section->{questionsPerPage} ) {
push( @{ $var{questionsPerPage} }, { 'index', $_, 'selected', 1 } ); push( @{ $var{questionsPerPage} }, { index => $index, selected => 1 } );
} }
else { else {
push( @{ $var{questionsPerPage} }, { 'index', $_, 'selected', 0 } ); push( @{ $var{questionsPerPage} }, { index => $index, selected => 0 } );
} }
} }
return \%var; return \%var;
} ## end sub getSectionEditVars
sub getGotoTargets {
my $self = shift;
my @section_vars = map {$_->{variable}} @{$self->sections};
my @question_vars = map {$_->{variable}} @{$self->questions};
return grep {$_ ne ''} (@section_vars, @question_vars);
} }
=head2 getQuestionEditVars ( $address ) =head2 getQuestionEditVars ( $address )
Get a safe copy of the variables for this question, to use for editing purposes. Adds Get a safe copy of the variables for this question, to use for editing purposes.
two variables, id, which is the indeces of the question's position in its parent's
section array joined by dashes '-', and displayed_id, which is this question's index Adds two variables:
in a 1-based array (versus the default, perl style, 0-based array).
=over 4
=item * id
the index of the question's position in its parent's section array joined by dashes '-'
=item * displayed_id
this question's index in a 1-based array (versus the default, perl style, 0-based array).
=back
It removes the answers array ref, and changes questionType from a single element, into It removes the answers array ref, and changes questionType from a single element, into
an array of hashrefs, which list the available question types and which one is currently an array of hashrefs, which list the available question types and which one is currently
@ -393,24 +437,29 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
sub getQuestionEditVars { sub getQuestionEditVars {
my $self = shift; my $self = shift;
my $address = shift; my $address = shift;
my $object = $self->question($address); my $question = $self->question($address);
my %var = %{$object}; my %var = %{$question};
$var{id} = $address->[0] . "-" . $address->[1];
$var{displayed_id} = $address->[1] + 1; # Add the extra fields..
$var{id} = sIndex($address) . "-" . qIndex($address);
$var{displayed_id} = qIndex($address) + 1;
# Remove the fields we don't want
delete $var{answers}; delete $var{answers};
delete $var{questionType}; delete $var{questionType};
my @types = $self->getValidQuestionTypes();
for (@types) { # Change questionType from a single element into an array of hashrefs which list the available
if ( $_ eq $object->{questionType} ) { # question types and which one is currently selected for this question..
push( @{ $var{questionType} }, { 'text', $_, 'selected', 1 } ); for ($self->getValidQuestionTypes) {
if ( $_ eq $question->{questionType} ) {
push( @{ $var{questionType} }, { text => $_, selected => 1 } );
} }
else { else {
push( @{ $var{questionType} }, { 'text', $_, 'selected', 0 } ); push( @{ $var{questionType} }, { text => $_, selected => 0 } );
} }
} }
return \%var; return \%var;
} ## end sub getQuestionEditVars }
=head2 getValidQuestionTypes =head2 getValidQuestionTypes
@ -435,10 +484,21 @@ sub getValidQuestionTypes {
=head2 getAnswerEditVars ( $address ) =head2 getAnswerEditVars ( $address )
Get a safe copy of the variables for this answer, to use for editing purposes. Adds Get a safe copy of the variables for this answer, to use for editing purposes.
two variables, id, which is the indeces of the answer's position in its parent's question
and section arrays joined by dashes '-', and displayed_id, which is this answer's index Adds two variables:
in a 1-based array (versus the default, perl style, 0-based array).
=over 4
=item * id
The index of the answer's position in its parent's question and section arrays joined by dashes '-'
=item * displayed_id
This answer's index in a 1-based array (versus the default, perl style, 0-based array).
=back
=head3 $address =head3 $address
@ -451,93 +511,104 @@ sub getAnswerEditVars {
my $address = shift; my $address = shift;
my $object = $self->answer($address); my $object = $self->answer($address);
my %var = %{$object}; my %var = %{$object};
$var{id} = $address->[0] . "-" . $address->[1] . "-" . $address->[2];
$var{displayed_id} = $address->[2] + 1; # Add the extra fields..
$var{id} = sIndex($address) . "-" . qIndex($address) . "-" . aIndex($address);
$var{displayed_id} = aIndex($address) + 1;
return \%var; return \%var;
} }
=head2 update ( $address, $object ) =head2 update ( $address, $properties )
Update new "objects" into the current data structure, or add new ones. It does not Update a section/question/answer with $properties, or add new ones.
return anything significant. Does not return anything significant.
=head3 $address =head3 $address
See L<"Address Parameter">. The number of elements array set what is updated. See L<"Address Parameter">.
The number of elements in $address determines the behaviour:
=over 4 =over 4
=item empty =item * 0 elements
If the array ref is empty, nothing is done. Do Nothing
=item 1 element =item * 1 element
If there's just 1 element, then that element is used as an index into Update the addressed section with $properties. If the section does not exist, such
the array of sections, and information from $object is used to replace
the properties of that section. If the select section does not exist, such
as by using an out of bounds array index, then a new section is appended as by using an out of bounds array index, then a new section is appended
to the list of sections. to the list of sections.
=item 2 elements =item * 2 elements
If there are 2 elements, then the first element is an index into Update the addressed question with $properties.
section array, and the second element is an index into the questions
in that section.
=item 3 elements =item * 3 elements
Three elements are enough to reference an answer, for a particular Update the addressed answer with $properties.
question in a section.
=back =back
=head3 $object =head3 $properties
A perl data structure. Note, that it is not checked for type, so it is A perl data structure. Note, that it is not checked for type, so it is
possible to add a "question" object into the list of section objects. possible to add a "question" object into the list of sections.
$object should never be a partial object, but contain all properties. $properties should never be a partial object, but contain all properties.
=cut =cut
sub update { sub update {
my ( $self, $address, $ref ) = @_; my ( $self, $address, $properties ) = @_;
my $object; my $object;
# Keep track of whether a new question is created along the way..
my $newQuestion = 0; my $newQuestion = 0;
if ( @$address == 1 ) {
# Figure out what to do by counting the number of elements in the $address array ref
my $count = @$address;
# First retrieve the addressed object, or, if necessary, create it
if ( $count == 1 ) {
$object = $self->section($address); $object = $self->section($address);
if ( !defined $object ) { if ( !defined $object ) {
$object = $self->newSection(); $object = $self->newSection();
push( @{ $self->sections }, $object ); push( @{ $self->sections }, $object );
} }
} }
elsif ( @$address == 2 ) { elsif ( $count == 2 ) {
$object = $self->question($address); $object = $self->question($address);
if ( !defined $object ) { if ( !defined $object ) {
my $newQuestion = 1;
$object = $self->newQuestion(); $object = $self->newQuestion();
$newQuestion = 1; # make note that a new question was created
push( @{ $self->questions($address) }, $object ); push( @{ $self->questions($address) }, $object );
} }
} }
elsif ( @$address == 3 ) { elsif ( $count == 3 ) {
$object = $self->answer($address); $object = $self->answer($address);
if ( !defined $object ) { if ( !defined $object ) {
$object = $self->newAnswer(); $object = $self->newAnswer();
push( @{ $self->answers($address) }, $object ); push( @{ $self->answers($address) }, $object );
} }
} }
if ( @$address == 2 and !$newQuestion ) {
if ( $ref->{questionType} ne $self->question($address)->{questionType} ) { # $object and $address now refer to the section/question/answer to be updated
$self->updateQuestionAnswers( $address, $ref->{questionType} );
# In the case where we are updating an existing question..
if ( $count == 2 and !$newQuestion ) {
# We need to update all of the answers to reflect the new questionType
if ( $properties->{questionType} ne $self->question($address)->{questionType} ) {
$self->updateQuestionAnswers( $address, $properties->{questionType} );
} }
} }
for my $key ( keys %$ref ) {
$object->{$key} = $ref->{$key} if ( defined $$ref{$key} );
}
} ## end sub update
#determine what to add and add it. # Update $object with all of the data in $properties
# ref should contain all the information for the new for my $key ( keys %$properties ) {
$object->{$key} = $properties->{$key} if defined $properties->{$key};
}
}
=head2 insertObject ( $object, $address ) =head2 insertObject ( $object, $address )
@ -1120,6 +1191,39 @@ sub answer {
return $self->{sections}->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers}->[ $address->[2] ]; return $self->{sections}->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers}->[ $address->[2] ];
} }
=head2 sIndex ($address)
Convenience sub to extract the section index from a standard $address parameter. See L<"Address Parameter">.
=cut
sub sIndex {
my $address = shift;
return $address->[0];
}
=head2 qIndex ($address)
Convenience sub to extract the question index from a standard $address parameter. See L<"Address Parameter">.
=cut
sub qIndex {
my $address = shift;
return $address->[1];
}
=head2 aIndex ($address)
Convenience sub to extract the answer index from a standard $address parameter. See L<"Address Parameter">.
=cut
sub aIndex {
my $address = shift;
return $address->[2];
}
=head2 log ($message) =head2 log ($message)
Logs an error message using the session logger. Logs an error message using the session logger.