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

Merge up to 10305

Browse source
This commit is contained in:
Colin Kuskie 2009-04-13 17:04:23 +00:00
parent fa2e5c2c90
commit 1edaca4ed2
65 changed files with 1300 additions and 477 deletions
Download patch file Download diff file Expand all files Collapse all files

27
lib/WebGUI/Asset/Event.pm
View file

@ -41,6 +41,14 @@ use WebGUI::DateTime;
=head1 Methods
=cut
####################################################################
=head2 addRevision ( )
Extent the method from the super class to handle iCalSequenceNumbers.
=cut
sub addRevision {
@ -1698,6 +1706,12 @@ sub processPropertiesFromFormPost {
#-------------------------------------------------------------------
=head2 purge ( )
Extent the method from the super class to delete all storage locations.
=cut
sub purge {
my $self = shift;
my $sth = $self->session->db->read("select storageId from Event where assetId=?",[$self->getId]);
@ -1711,6 +1725,12 @@ sub purge {
#-------------------------------------------------------------------
=head2 purgeRevision ( )
Extent the method from the super class to delete the storage location for this revision.
=cut
sub purgeRevision {
my $self = shift;
$self->getStorageLocation->delete;
@ -1908,6 +1928,13 @@ sub view {
#-------------------------------------------------------------------
=head2 www_deleteFile ( )
Delete a file given in the form variable "filename" from the storage location.
=cut
sub www_deleteFile {
my $self = shift;
$self->getStorageLocation->deleteFile($self->session->form->process("filename")) if $self->canEdit;

7
lib/WebGUI/Asset/MatrixListing.pm
View file

@ -640,6 +640,13 @@ sub view {
$var->{manufacturerUrl_click} = $self->getUrl("func=click;manufacturer=1");
$var->{productUrl_click} = $self->getUrl("func=click");
if($self->get('status') eq 'pending'){
my $revisionDate = $self->get('revisionDate');
$var->{revision} = $revisionDate;
$var->{manufacturerUrl_click} .= ';revision='.$revisionDate;
$var->{productUrl_click} .= ';revision='.$revisionDate;
}
$self->session->style->setScript($self->session->url->extras('yui/build/yahoo/yahoo-min.js'),
{type => 'text/javascript'});
$self->session->style->setScript($self->session->url->extras('yui/build/dom/dom-min.js'),

42
lib/WebGUI/Asset/Wobject/Article.pm
View file

@ -144,6 +144,12 @@ sub definition {
#-------------------------------------------------------------------
=head2 duplicate ( )
Extend the super class to duplicate the storage location.
=cut
sub duplicate {
my $self = shift;
my $newAsset = $self->SUPER::duplicate(@_);
@ -169,6 +175,14 @@ sub exportAssetData {
#-------------------------------------------------------------------
=head2 getStorageLocation ( )
Fetches the storage location for this asset. If it does not have one,
then make one. Build an internal cache of the storage object.
=cut
sub getStorageLocation {
my $self = shift;
unless (exists $self->{_storageLocation}) {
@ -223,6 +237,13 @@ sub prepareView {
#-------------------------------------------------------------------
=head2 processPropertiesFromFormPost ( )
Extend the super class to calculate total asset size from
any files stored in the storage location.
=cut
sub processPropertiesFromFormPost {
my $self = shift;
$self->SUPER::processPropertiesFromFormPost(@_);
@ -235,6 +256,15 @@ sub processPropertiesFromFormPost {
}
#-------------------------------------------------------------------
=head2 update ( )
Extend the super class to handle the storage location. Sets
the correct privileges and deletes the internally cached
Storage object.
=cut
sub update {
my $self = shift;
my $previousStorageId = $self->get('storageId');
@ -253,6 +283,12 @@ sub update {
#-------------------------------------------------------------------
=head2 purge ( )
Extend the super class to delete all storage locations.
=cut
sub purge {
my $self = shift;
my $sth = $self->session->db->read("select storageId from Article where assetId=?",[$self->getId]);
@ -280,6 +316,12 @@ sub purgeCache {
#-------------------------------------------------------------------
=head2 purgeRevision ( )
Extend the super class to delete the storage location for this revision.
=cut
sub purgeRevision {
my $self = shift;
$self->getStorageLocation->delete;

63
lib/WebGUI/Asset/Wobject/Carousel.pm
View file

@ -40,7 +40,7 @@ sub definition {
%properties = (
templateId =>{
fieldType =>"template",
defaultValue =>'CarouselTmpl0000000002',
defaultValue =>'CarouselTmpl0000000001',
tab =>"display",
noFormPost =>0,
namespace =>"Carousel",
@ -273,66 +273,5 @@ adminConsole views.
# return $self->getAdminConsole->render($self->getEditForm->print, $i18n->get("edit title"));
#}
#-------------------------------------------------------------------
# Everything below here is to make it easier to install your custom
# wobject, but has nothing to do with wobjects in general
#-------------------------------------------------------------------
# cd /data/WebGUI/lib
# perl -MWebGUI::Asset::Wobject::Carousel -e install www.example.com.conf [ /path/to/WebGUI ]
# - or -
# perl -MWebGUI::Asset::Wobject::Carousel -e uninstall www.example.com.conf [ /path/to/WebGUI ]
#-------------------------------------------------------------------
use base 'Exporter';
our @EXPORT = qw(install uninstall);
use WebGUI::Session;
#-------------------------------------------------------------------
sub install {
my $config = $ARGV[0];
my $home = $ARGV[1] || "/data/WebGUI";
die "usage: perl -MWebGUI::Asset::Wobject::Carousel -e install www.example.com.conf\n" unless ($home && $config);
print "Installing asset.\n";
my $session = WebGUI::Session->open($home, $config);
my $assets = $session->config->get( "assets" );
$assets->{ "WebGUI::Asset::Wobject::Carousel" } = { category => "utilities" };
$session->config->set( "assets", $assets );
#$session->config->addToArray("assets","WebGUI::Asset::Wobject::Carousel");
$session->db->write("create table Carousel (
assetId char(22) binary not null,
revisionDate bigint not null,
items mediumtext,
templateId char(22),
primary key (assetId, revisionDate)
)");
$session->var->end;
$session->close;
print "Done. Please restart Apache.\n";
}
#-------------------------------------------------------------------
sub uninstall {
my $config = $ARGV[0];
my $home = $ARGV[1] || "/data/WebGUI";
die "usage: perl -MWebGUI::Asset::Wobject::Carousel -e uninstall www.example.com.conf\n" unless ($home && $config);
print "Uninstalling asset.\n";
my $session = WebGUI::Session->open($home, $config);
$session->config->deleteFromArray("assets","WebGUI::Asset::Wobject::Carousel");
my $rs = $session->db->read("select assetId from asset where className='WebGUI::Asset::Wobject::Carousel'");
while (my ($id) = $rs->array) {
my $asset = WebGUI::Asset->new($session, $id, "WebGUI::Asset::Wobject::Carousel");
$asset->purge if defined $asset;
}
$session->db->write("drop table Carousel");
$session->var->end;
$session->close;
print "Done. Please restart Apache.\n";
}
1;
#vim:ft=perl

13
lib/WebGUI/Asset/Wobject/Collaboration.pm
View file

@ -1452,5 +1452,18 @@ sub www_view {
return $self->next::method(@_);
}
#-------------------------------------------------------------------
=head2 www_viewRSS ( )
Deprecated. Use www_viewRss() instead.
=cut
sub www_viewRSS {
my $self = shift;
return $self->www_viewRss;
}
1;

6
lib/WebGUI/Asset/Wobject/Matrix.pm
View file

@ -567,6 +567,8 @@ sub view {
$varStatistics = JSON->new->decode($varStatisticsEncoded);
}
else{
$varStatistics->{alphanumeric_sortButton} = "<span id='sortByName'><button type='button'>Sort by name</button></span><br />";
# Get the MatrixListing with the most views as an object using getLineage.
my ($bestViews_listing) = @{ $self->getLineage(['descendants'], {
includeOnlyClasses => ['WebGUI::Asset::MatrixListing'],
@ -629,7 +631,7 @@ sub view {
lastUpdated => $self->session->datetime->epochToHuman($lastUpdatedListing->get('lastUpdated'),"%z")
});
}
$var->{lastUpdated_sortButton} = "<span id='sortByUpdated'><button type='button'>Sort by updated</button></span><br />";
$varStatistics->{lastUpdated_sortButton} = "<span id='sortByUpdated'><button type='button'>Sort by updated</button></span><br />";
# For each category, get the MatrixListings with the best ratings.
@ -1302,7 +1304,7 @@ sub www_search {
$options{'blank'} = 'blank';
$attribute->{options} = \%options;
$attribute->{value} = 'blank';
$attribute->{extras} = "style='width:120px'";
$attribute->{extras} .= " style='width:120px'";
}
$attribute->{form} = WebGUI::Form::DynamicField->new($self->session,%{$attribute})->toHtml;
push(@attribute_loop,$attribute);

23
lib/WebGUI/Asset/Wobject/Navigation.pm
View file

@ -84,6 +84,13 @@ sub definition {
}
#-------------------------------------------------------------------
=head2 getEditForm ( )
Manually build the edit form due to javascript elements.
=cut
sub getEditForm {
my $self = shift;
my $tabform = $self->SUPER::getEditForm;
@ -340,7 +347,7 @@ sub getToolbar {
=head2 prepareView ( )
See WebGUI::Asset::prepareView() for details.
Extend the superclass to add metadata and to preprocess the template.
=cut
@ -354,6 +361,13 @@ sub prepareView {
#-------------------------------------------------------------------
=head2 view ( )
See WebGUI::Asset::view() for details.
=cut
sub view {
my $self = shift;
# we've got to determine what our start point is based upon user conditions
@ -512,6 +526,13 @@ sub view {
}
#-------------------------------------------------------------------
=head2 www_goBackToPage ( )
Do a redirect to the form parameter returnUrl if it exists.
=cut
sub www_goBackToPage {
my $self = shift;
$self->session->http->setRedirect($self->session->form->process("returnUrl")) if ($self->session->form->process("returnUrl"));

15
lib/WebGUI/Asset/Wobject/SQLReport.pm
View file

@ -220,6 +220,13 @@ sub definition {
}
#-------------------------------------------------------------------
=head2 getEditForm ( )
Manually make the edit form due to javascript for adding more queries.
=cut
sub getEditForm {
my $self = shift;
my $tabform = $self->SUPER::getEditForm();
@ -495,6 +502,14 @@ sub purgeCache {
}
#-------------------------------------------------------------------
=head2 view ( )
See WebGUI::Asset::view() for details. This method also performs content caching
if the user is not in Admin Mode.
=cut
sub view {
my $self = shift;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {

53
lib/WebGUI/Asset/Wobject/Survey.pm
View file

@ -396,6 +396,7 @@ Loads the initial edit survey page. All other edit actions are ajax calls from t
sub www_editSurvey {
my $self = shift;
return $self->session->privilege->insufficient()
if !$self->session->user->isInGroup( $self->get('groupToEditSurvey') );
@ -676,7 +677,7 @@ sub www_dragDrop {
#If target is being moved down, then before has just moved up do to the target being deleted
$bid[0]-- if($tid[0] < $bid[0]);
$self->surveyJSON->insertObject( $target, [ $bid[0] ] );
$address = $self->surveyJSON->insertObject( $target, [ $bid[0] ] );
}
elsif ( @tid == 2 ) { #questions can be moved to any section, but a pushed to the end of a new section.
if ( $bid[0] !~ /\d/ ) {
@ -700,21 +701,21 @@ sub www_dragDrop {
else{ #Moved within the same section
$bid[1]-- if($tid[1] < $bid[1]);
}
$self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1] ] );
$address = $self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1] ] );
} ## end elsif ( @tid == 2 )
elsif ( @tid == 3 ) { #answers can only be rearranged in the same question
if ( @bid == 2 and $bid[1] == $tid[1] ) {#moved to the top of the question
$bid[2] = -1;
$self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1], $bid[2] ] );
$address = $self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1], $bid[2] ] );
}
elsif ( @bid == 3 ) {
#If target is being moved down, then before has just moved up do to the target being deleted
$bid[2]-- if($tid[2] < $bid[2]);
$self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1], $bid[2] ] );
$address = $self->surveyJSON->insertObject( $target, [ $bid[0], $bid[1], $bid[2] ] );
}
else {
#else put it back where it was
$self->surveyJSON->insertObject( $target, \@tid );
$address = $self->surveyJSON->insertObject( $target, \@tid );
}
}
@ -742,6 +743,7 @@ sub www_loadSurvey {
my ( $self, $options ) = @_;
my $editflag = 1;
my $address = defined $options->{address} ? $options->{address} : undef;
if ( !defined $address ) {
if ( my $inAddress = $self->session->form->process('data') ) {
if ( $inAddress eq q{-} ) {
@ -760,7 +762,7 @@ sub www_loadSurvey {
= defined $options->{var}
? $options->{var}
: $self->surveyJSON->getEditVars($address);
my $editHtml;
if ( $var->{type} eq 'section' ) {
$editHtml = $self->processTemplate( $var, $self->get('sectionEditTemplateId') );
@ -903,7 +905,7 @@ returns the output.
sub view {
my $self = shift;
my $var = $self->getMenuVars;
my ( $code, $overTakeLimit ) = $self->getResponseInfoForView();
$var->{lastResponseCompleted} = $code;
@ -1153,13 +1155,23 @@ sub www_submitQuestions {
}
#-------------------------------------------------------------------
sub getSummary{
=head2 getSummary
Returns a copy of the summary stored in JSON, and the output of
the survey summary template.
=cut
sub getSummary {
my $self = shift;
my $summary = $self->responseJSON->showSummary();
my $out = $self->processTemplate( $summary, $self->get('surveySummaryTemplateId') );
return $out;
return ($summary,$out);
# return $self->session->style->process( $out, $self->get('styleTemplateId') );
}
#-------------------------------------------------------------------
=head2 www_loadQuestions
@ -1171,7 +1183,6 @@ Determines which questions to display to the survey taker next, loads and return
sub www_loadQuestions {
my $self = shift;
my $wasRestarted = shift;
if ( !$self->canTakeSurvey() ) {
$self->session->log->debug('canTakeSurvey false, surveyEnd');
return $self->surveyEnd();
@ -1191,7 +1202,8 @@ sub www_loadQuestions {
$self->session->log->debug('Response surveyEnd, so calling surveyEnd');
if ( $self->get('quizModeSummary') ) {
if(! $self->session->form->param('shownsummary')){
my $json = to_json( { type => 'summary', summary => $self->getSummary() });
my ($summary,$html) = $self->getSummary();
my $json = to_json( { type => 'summary', summary => $summary, html => $html });
return $json;
}
}
@ -1750,7 +1762,7 @@ sub www_viewStatisticalOverview {
#-------------------------------------------------------------------
=head2 www_exportTransposedResults ()
=head2 www_exportSimpleResults ()
Exports transposed results in a tab deliniated file.
@ -1908,4 +1920,21 @@ sub www_editDefaultQuestions{
}
#-------------------------------------------------------------------
=head2 www_downloadDefaulQuestions
Sends the user a json file of the default question types, which can be imported to other WebGUI instances.
=cut
sub www_downloadDefaultQuestionTypes{
my $self = shift;
return $self->session->privilege->insufficient()
if !$self->session->user->isInGroup( $self->get('groupToViewReports') );
my $content = to_json($self->surveyJSON->{multipleChoiceTypes});
return $self->export( "WebGUI-Survey-DefaultQuestionTypes.json", $content );
}
1;

205
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
View file

@ -8,6 +8,10 @@ Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
This class is used to process Survey gotoExpressions.
If you want to allow the expression engine to run you need to turn on the enableSurveyExpressionEngine flag
in your site config file. This is because no matter how 'Safe' the Safe.pm compartment is, it still has
caveats. For example, it doesn't protect you from infinite loops.
See L<run> for more details.
=cut
@ -17,6 +21,7 @@ use Params::Validate qw(:all);
use Safe;
use Data::Dumper;
use List::Util qw/sum/;
use WebGUI::Asset;
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
# We need these as semi-globals so that utility subs (which are shared with the safe compartment)
@ -27,20 +32,39 @@ my $scores;
my $jump_count;
my $validate;
my $validTargets;
my $other_instances;
=head2 value
Utility sub that gives expressions access to recorded response values
value(question_variable) returns the recorded response value for the answer to question_variable
value(asset_spec, question_variable) returns value(question_variable) on the most recent completed response
for the user on the survey instance given by asset_spec (either an assetId or a url)
=cut
sub value($) {
sub value {
# Two arguments implies the first arg is an asset_spec
if ( @_ == 2 ) {
my ( $asset_spec, $key ) = @_;
# See if $other_instances already contains the external survey
if (my $other_instance = $other_instances->{$asset_spec}) {
my $values = $other_instance->{values};
my $value = $values->{$key};
$session->log->debug("[$asset_spec, $key] resolves to [$value]");
return $value;
} else {
# Throw an exception, triggering run() to resolve the external reference and re-run
die( { other_instance => $asset_spec } );
}
}
my $key = shift;
my $value = $values->{$key};
$session->log->debug("[$key] resolves to [$value]");
return $value; # scalar variable, so no need to clone
return $value; # scalar variable, so no need to clone
}
=head2 score
@ -52,11 +76,26 @@ score(section_variable) returns the summed score for the answers to all the ques
=cut
sub score($) {
sub score {
# Two arguments implies the first arg is an asset_spec
if ( @_ == 2 ) {
my ( $asset_spec, $key ) = @_;
# See if $other_instances already contains the external survey
if (my $other_instance = $other_instances->{$asset_spec}) {
my $scores = $other_instance->{scores};
my $score = $scores->{$key};
$session->log->debug("[$asset_spec, $key] resolves to [$score]");
return $score;
} else {
# Throw an exception, triggering run() to resolve the external reference and re-run
die( { other_instance => $asset_spec } );
}
}
my $key = shift;
my $score = $scores->{$key};
$session->log->debug("[$key] resolves to [$score]");
return $score; # scalar variable, so no need to clone
return $score; # scalar variable, so no need to clone
}
=head2 jump
@ -71,17 +110,18 @@ catch the first successful jump.
sub jump(&$) {
my ( $sub, $target ) = @_;
$jump_count++;
# If $validTargets known, make sure target is valid
if ($validTargets && !exists $validTargets->{$target}) {
if ( $validTargets && !exists $validTargets->{$target} ) {
$session->log->debug("Invalid target [$target]");
if ($validate) {
die("Invalid jump target \"$target\""); # bail and report error
} else {
return; # skip jump but continue with expression
die("Invalid jump target \"$target\""); # bail and report error
}
else {
return; # skip jump but continue with expression
}
}
if ( $sub->() ) {
$session->log->debug("jump call #$jump_count is truthy");
die( { jump => $target } );
@ -120,8 +160,12 @@ A gotoExpression is essentially a perl expression that gets evaluated in a Safe
To access Section/Question recorded response values, the expression calls L<value>.
To access Section/Question recorded response scores, the expression calls L<score>.
Both L<value> and L<score> allow you to resolve values and scores from other completed survey
instances.
To trigger a jump, the expression calls L<jump>. The first truthy jump succeeds.
We also give expressions access to some useful utility subs such as avg(), and all of the
Expressions also have access to some useful utility subs such as avg(), and all of the
handy subs from List::Util (min, max, sum, etc..).
A very simple expression that checks if the response to s1q1 is 0 might look like:
@ -131,7 +175,7 @@ A very simple expression that checks if the response to s1q1 is 0 might look lik
A more complicated gotoExpression with two possible jumps might look like:
jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1;
jump { avg(value(q1), value(q2), value(q3)) > 10 } target2;
jump { avg(value(q1), value(q2), value(home/anotherSurvey, q3)) > 10 } target2;
=head3 opts (optional)
@ -147,7 +191,7 @@ Hashref of values to make available to the expression via the L<value> utility s
Hashref of scores to make available to the expression via the L<score> utility sub
=item* validTargets
=item * validTargets
A hashref of valid jump targets. If this is provided, all L<jump> calls will fail unless
the specified target is a key in the hashref.
@ -166,52 +210,113 @@ sub run {
= validate_pos( @_, { isa => 'WebGUI::Session' }, { type => SCALAR }, { type => HASHREF, default => {} } );
# Init package globals
( $session, $values, $scores, $jump_count, $validate, $validTargets ) = ( $s, $opts->{values}, $opts->{scores}, 0, $opts->{validate}, $opts->{validTargets} );
if (!$session->config->get('enableSurveyExpressionEngine')) {
( $session, $values, $scores, $jump_count, $validate, $validTargets )
= ( $s, $opts->{values}, $opts->{scores}, 0, $opts->{validate}, $opts->{validTargets} );
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
$session->log->debug('enableSurveyExpressionEngine config option disabled, skipping');
return;
}
# Create the Safe compartment
my $compartment = Safe->new();
REVAL: {
# Share our utility subs with the compartment
$compartment->share('&value');
$compartment->share('&score');
$compartment->share('&jump');
$compartment->share('&avg');
# Give them all of List::Util too
$compartment->share_from('List::Util', ['&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum',]);
# Create the Safe compartment
my $compartment = Safe->new();
$session->log->debug("Expression is: \"$expression\"");
$compartment->reval($expression);
# See if we ran the engine just to check for errors
if ($opts->{validate}) {
if ($@ && ref $@ ne 'HASH') {
my $error = $@;
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much
return $error;
# Share our utility subs with the compartment
$compartment->share('&value');
$compartment->share('&score');
$compartment->share('&jump');
$compartment->share('&avg');
# Give them all of List::Util too
$compartment->share_from( 'List::Util',
[ '&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum', ] );
$session->log->debug("Expression is: \"$expression\"");
$compartment->reval($expression);
# See if we ran the engine just to check for errors
if ( $opts->{validate} ) {
if ( $@ && ref $@ ne 'HASH' ) {
my $error = $@;
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much
return $error;
}
return; # no validation errors
}
return; # no validation errors
}
# 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;
}
# 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;
}
# Log all other errors (for example compile errors from bad expressions)
if ($@) {
$session->log->error($@);
}
# See if an unresolved external reference was encountered
if ( ref $@ && ref $@ eq 'HASH' && $@->{other_instance} ) {
my $asset_spec = $@->{other_instance};
$session->log->debug("Resolving external reference: $asset_spec");
my $asset;
# Return undef on failure
return;
# Instantiate the asset to check it is a Survey instance, and to grab its assetId
if ( $session->id->valid($asset_spec) ) {
$asset = WebGUI::Asset->new( $session, $asset_spec );
}
if ( !$asset ) {
$asset = WebGUI::Asset->newByUrl( $session, $asset_spec );
}
if ( ref $asset ne 'WebGUI::Asset::Wobject::Survey' ) {
$session->log->warn("Not a survey instance: $asset_spec");
return;
}
if ( !$asset ) {
$session->log->warn("Unable to find asset: $asset_spec");
return;
}
my $assetId = $asset->getId;
# Get the responseId of the most recently completed survey response for the user
my $userId = $opts->{userId} || $session->user->userId;
my $mostRecentlyCompletedResponseId = $session->db->quickScalar(
"select Survey_responseId from Survey_response where userId = ? and assetId = ? and isComplete = 1",
[ $userId, $assetId ]
);
if ( !$mostRecentlyCompletedResponseId ) {
$session->log->debug("User $userId has not completed Survey");
return;
}
$session->log->debug("Using responseId: $mostRecentlyCompletedResponseId");
# (re)Instantiate the survey instance using the responseId
use WebGUI::Asset::Wobject::Survey;
$asset = WebGUI::Asset::Wobject::Survey->newByResponseId( $session, $mostRecentlyCompletedResponseId );
$asset->responseIdCookies(0);
if ( !$asset ) {
$session->log->warn("Unable to instantiate asset by responseId: $mostRecentlyCompletedResponseId");
return;
}
$other_instances->{$asset_spec} = {
values =>
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseValuesByVariableName,
scores =>
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseScoresByVariableName,
};
$session->log->debug("Successfully looked up asset: $assetId. Repeating reval.");
redo REVAL;
}
# Log all other errors (for example compile errors from bad expressions)
if ($@) {
$session->log->error($@);
}
# Return undef on failure
return;
}
}
1;

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

@ -85,7 +85,7 @@ Answers entries contain: value (the recorded value), time and comment fields.
{
...
answerId => {
value => "answer value",
value => "recorded answer value",
time => time(),
comment => "answer comment",
},
@ -738,12 +738,18 @@ sub responseValuesByVariableName {
# Grab the corresponding question
my $question = $self->survey->question([@address]);
# Filter out questions without defined variable names
next if !$question || !defined $question->{variable};
#Test if question is a multiple choice type so we can use the answer text instead
my $answerText;
if($self->survey->getMultiChoiceBundle($question->{questionType})){
$answerText = $self->survey->answer([@address])->{text};
}
# Add variable => value to our hash
$lookup{$question->{variable}} = $response->{value};
$lookup{$question->{variable}} = $answerText ? $answerText : $response->{value};
}
return \%lookup;
}
@ -781,8 +787,11 @@ sub responseScoresByVariableName {
# Grab the corresponding answer
my $answer = $self->survey->answer([@address]);
# Use question score if answer score undefined
my $score = (exists $answer->{value} && length $answer->{value} > 0) ? $answer->{value} : $question->{value};
# Add variable => score to our hash
$lookup{$question->{variable}} = $answer->{value};
$lookup{$question->{variable}} = $score;
}
# Add section score totals
@ -1074,9 +1083,8 @@ sub showSummary{
return if(! $responses);
my ($sectionIndex, $questionIndex, $answerIndex) = (-1, -1, -1);
my ($currentSection,$currentQuestion) = (-1, -1);
my ($sectionIndex, $responseIndex) = (-1, 1);
my ($currentSection,$currentQuestion) = (-1,-1);
($summaries->{totalCorrect},$summaries->{totalIncorrect}) = (0,0);
for my $response (@$responses){
@ -1090,62 +1098,54 @@ sub showSummary{
if($currentSection != $response->{address}->[0]){
$summaries->{totalSections}++;
$sectionIndex++;
$questionIndex = -1;
$answerIndex = -1;
$currentQuestion = -1;
$responseIndex = -1;
$currentSection = $response->{address}->[0];
_loadSectionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]},$response);
}
if($currentQuestion != $response->{address}->[1]){
$summaries->{totalQuestions}++;
$questionIndex++;
$answerIndex = -1;
$currentQuestion = $response->{address}->[1];
_loadQuestionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{questions}->[$questionIndex]},$response);
}
$answerIndex++;
_loadAnswerIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{questions}->[$questionIndex]->{answers}->[$answerIndex]},
_loadSectionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]}, $response);
$responseIndex++;
_loadResponseIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{responses}->[$responseIndex]},
$response,
$self->survey->{multipleChoiceTypes});
}
return $summaries;
}
sub _loadAnswerIntoSummary{
sub _loadResponseIntoSummary{
my $node = shift;
my $response = shift;
my $types = shift;
$node->{id} = $response->{address}->[2] + 1;
$node->{"Question ID"} = $response->{address}->[1] + 1;
$node->{"Question Text"} = $response->{questionText};
$node->{"Answer ID"} = $response->{address}->[2] + 1;
if($response->{isCorrect}){
$node->{iscorrect} = 1;
$node->{score} = $response->{value};
$node->{Correct} = "Y";
$node->{Score} = $response->{value};
}else{
$node->{iscorrect} = 0;
$node->{score} = 0;
$node->{Correct} = "N";
$node->{Score} = 0;
}
$node->{text} = $response->{answerText};
$node->{"Answer Text"} = $response->{answerText};
#test if it is a multiple choide type
if($types->{$response->{questionType}}){
$node->{value} = $response->{value};
$node->{Value} = $response->{value};
}else{
$node->{value} = $response->{recordedValue};
$node->{Value} = $response->{recordedValue};
}
}
sub _loadQuestionIntoSummary{
my $node = shift;
my $response = shift;
$node->{id} = $response->{address}->[1] + 1;
$node->{text} = $response->{questionText};
}
sub _loadSectionIntoSummary{
my $node = shift;
my $response = shift;
$node->{id} = $response->{address}->[0] + 1;
$node->{inCorrect} = 0 if(!defined $node->{section}->{inCorrect});
$node->{score} = 0 if(!defined $node->{section}->{score});
$node->{correct} = 0 if(!defined $node->{section}->{correct});
if($response->{isCorrect}){
$node->{inCorrect} = 0 if(!defined $node->{inCorrect});
$node->{score} = 0 if(!defined $node->{score});
$node->{correct} = 0 if(!defined $node->{correct});
$node->{total} = 0 if(!defined $node->{total});
$node->{total}++;
if($response->{isCorrect} == 1){
$node->{score} += $response->{value};
$node->{correct}++;
}else{

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

@ -110,6 +110,7 @@ Loads the Multiple Choice and Special Question types
sub loadTypes {
my $self = shift;
@{$self->{specialQuestionTypes}} = (
'Dual Slider - Range',
'Multi Slider - Allocate',
@ -125,9 +126,11 @@ sub loadTypes {
'Date Range',
'Year Month',
'Hidden',
);
my $refs = $self->session->db->buildArrayRefOfHashRefs("SELECT questionType, answers FROM Survey_questionTypes");
map($self->{multipleChoiceTypes}->{$_->{questionType}} = [split/,/,$_->{answers}], @$refs);
) if(! defined $self->{specialQuestionTypes});
if(! defined $self->{multipleChoiceTypes}){
my $refs = $self->session->db->buildArrayRefOfHashRefs("SELECT questionType, answers FROM Survey_questionTypes");
map($self->{multipleChoiceTypes}->{$_->{questionType}} = $_->{answers} ? from_json($_->{answers}) : {}, @$refs);
}
}
sub addType {
@ -135,11 +138,7 @@ sub addType {
my $name = shift;
my $address = shift;
my $obj = $self->getObject($address);
my @answers;
for my $ans(@{$obj->{answers}}){
push(@answers,$ans->{text});
}
my $ansString = join(',',@answers);
my $ansString = $obj->{answers} ? to_json $obj->{answers} : {};
$self->session->db->write("INSERT INTO Survey_questionTypes VALUES(?,?) ON DUPLICATE KEY UPDATE answers = ?",[$name,$ansString,$ansString]);
$self->question($address)->{questionType} = $name;
}
@ -391,7 +390,6 @@ sections, questions, or answers.
sub getEditVars {
my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF });
# Figure out what to do by counting the number of elements in the $address array ref
my $count = @{$address};
@ -727,15 +725,18 @@ sub insertObject {
# Use splice to rearrange the relevant array of objects..
if ( $count == 1 ) {
splice @{ $self->sections($address) }, sIndex($address) +1, 0, $object;
$address->[0]++;
}
elsif ( $count == 2 ) {
splice @{ $self->questions($address) }, qIndex($address) + 1, 0, $object;
$address->[1]++;
}
elsif ( $count == 3 ) {
splice @{ $self->answers($address) }, aIndex($address) + 1, 0, $object;
$address->[2]++;
}
return;
return $address;
}
=head2 copy ( $address )
@ -988,16 +989,8 @@ sub updateQuestionAnswers {
}
elsif ( my $answerBundle = $self->getMultiChoiceBundle($type) ) {
# We found a known multi-choice bundle.
# Mark any answer containing the string "verbatim" as verbatim
my $verbatims = {};
for my $answerIndex (0 .. $#$answerBundle) {
if ($answerBundle->[$answerIndex] =~ /\(verbatim\)/) {
$verbatims->{$answerIndex} = 1;
}
}
# Add the bundle of multi-choice answers, along with the verbatims hash
$self->addAnswersToQuestion( \@address_copy, $answerBundle, $verbatims );
# Add the bundle of multi-choice answers
$self->addAnswersToQuestion( \@address_copy, $answerBundle );
} else {
# Default action is to add a single, default answer to the question
push @{ $question->{answers} }, $self->newAnswer();
@ -1008,9 +1001,7 @@ sub updateQuestionAnswers {
=head2 getMultiChoiceBundle
Returns a list of answers for each multi-choice bundle.
Currently these are hard-coded but soon they will live in the database.
Returns a list of answer objects for each multi-choice bundle.
=cut
@ -1021,7 +1012,7 @@ sub getMultiChoiceBundle {
return $self->{multipleChoiceTypes}->{$type};
}
=head2 addAnswersToQuestion ($address, $answers, $verbatims)
=head2 addAnswersToQuestion ($address, $answers)
Helper routine for updateQuestionAnswers. Adds an array of answers to a question.
@ -1034,39 +1025,21 @@ See L<"Address Parameter">. The address of the question to add answers to.
An array reference of answers to add. Each element will be assigned to the text field of
the answer that is created.
=head3 $verbatims
An hash reference. Each key is an index into the answers array. The value is a placeholder
for doing existance lookups. For each requested index, the verbatim flag in the answer is
set to true.
=cut
sub addAnswersToQuestion {
my $self = shift;
my ( $address, $answers, $verbatims )
= validate_pos( @_, { type => ARRAYREF }, { type => ARRAYREF }, { type => HASHREF } );
my ( $address, $answers )
= validate_pos( @_, { type => ARRAYREF }, { type => ARRAYREF } );
# Make a private copy of the $address arrayref that we can use locally
# when updating answer text without causing side-effects for the caller's $address
my @address_copy = @{$address};
for my $answer_index ( 0 .. $#{$answers} ) {
# Add a new answer to question
push @{ $self->question( \@address_copy )->{answers} }, $self->newAnswer();
# Update address to point at newly created answer (so that we can update it)
$address_copy[2] = $answer_index;
# Update the answer appropriately
$self->update(
\@address_copy,
{ text => $answers->[$answer_index],
recordedAnswer => $answer_index + 1, # 1-indexed
verbatim => $verbatims->{$answer_index},
}
);
push @{ $self->question( \@address_copy )->{answers} }, $answers->[$answer_index];
}
return;
@ -1200,15 +1173,12 @@ Returns an array of messages to inform a user what is logically wrong with the S
sub validateSurvey{
my $self = shift;
#check all goto's
#bad goto expressions
#check that all survey is able to be seen
my @messages;
#set up valid goto targets
my $gotoTargets = $self->getGotoTargets();
my $goodTargets;
my $goodTargets = {};
my $duplicateTargets;
for my $g (@{$gotoTargets}) {
$goodTargets->{$g}++;
@ -1302,7 +1272,11 @@ sub validateGotoExpression{
my $self = shift;
my $object = shift;
my $goodTargets = shift;
return unless $object->{gotoExpression};
return unless $object->{gotoExpression};
if (!$self->session->config->get('enableSurveyExpressionEngine')) {
return 'enableSurveyExpressionEngine is disabled in your site config!';
}
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";

14
lib/WebGUI/Asset/Wobject/SyndicatedContent.pm
View file

@ -403,20 +403,6 @@ sub www_viewRSS10 {
return $self->www_viewRdf;
}
#-------------------------------------------------------------------
=head2 www_viewRSS ( )
Deprecated. Use www_viewRss() instead.
=cut
sub www_viewRSS {
my $self = shift;
return $self->www_viewRss;
}
#-------------------------------------------------------------------
=head2 www_viewRSS20 ( )

9
lib/WebGUI/Asset/Wobject/Thingy.pm
View file

@ -3152,6 +3152,9 @@ sub getSearchTemplateVars {
$currentUrl = $self->getUrl();
foreach ($self->session->form->param) {
# if we just saved data from an edit, we do not want to keep any of the params
last if $_ eq 'func' and $self->session->form->process($_) eq 'editThingDataSave';
unless ($_ eq "pn" || $_ eq "op" || $_ =~ /identifier/xi || $_ =~ /password/xi || $_ eq "orderBy" ||
$self->session->form->process($_) eq "") {
$currentUrl = $self->session->url->append($currentUrl,$self->session->url->escape($_)
@ -3260,10 +3263,16 @@ sequenceNumber');
$templateVars{canEditThingData} = 1;
$templateVars{searchResult_delete_icon} = $session->icon->delete('func=deleteThingDataConfirm;thingId='
.$thingId.';thingDataId='.$thingDataId,$self->get("url"),$i18n->get('delete thing data warning'));
$templateVars{searchResult_delete_url} = $session->url->append($url,
'func=deleteThingDataConfirm;thingId='.$thingId.';thingDataId='.$thingDataId);
$templateVars{searchResult_edit_icon} = $session->icon->edit('func=editThingData;thingId='
.$thingId.';thingDataId='.$thingDataId,$self->get("url"));
$templateVars{searchResult_edit_url} = $session->url->append($url,
'func=editThingData;thingId='.$thingId.';thingDataId='.$thingDataId);
$templateVars{searchResult_copy_icon} = $session->icon->copy('func=copyThingData;thingId='
.$thingId.';thingDataId='.$thingDataId,$self->get("url"));
$templateVars{searchResult_copy_url} = $session->url->append($url,
'func=copyThingData;thingId='.$thingId.';thingDataId='.$thingDataId,);
}
push(@searchResult_loop,\%templateVars);
}

52
lib/WebGUI/AssetAspect/RssFeed.pm
View file

@ -252,12 +252,35 @@ sub exportAssetCollateral {
=head2 getRssFeedItems ()
This method should throw an exception if it's not overridden. Its intention is
to be overridden by whatever class is using it and should return an array
reference of hash references. Each hash reference should contain at minimum a title,
description, link, and date field. The date field can be either an epoch date, an RFC 1123
date, or a ISO date in the format of YYYY-MM-DD HH:MM::SS. Optionally specify an
author, and a guid field.
This method needs to be overridden by any class that is using it. To ensure
this, it will throw an exception.
It returns an array reference of hash references. The list below shows
which ones are required, along with some common keys which are optional.
Other keys may be added, as well.
=head3 Hash reference keys
=head4 title
=head4 description
=head4 link
This is a url to the item.
=head4 date
An epoch date, an RFC 1123 date, or a date in ISO format (referred to as MySQL format
inside WebGUI)
=head4 author
This is optional.
=head4 guid
This is optional. A unique descriptor for this item.
=cut
@ -405,12 +428,29 @@ sub getFeed {
return $feed;
}
#-------------------------------------------------------------------
=head2 prepareView ()
Extend the master class to insert head links via addHeaderLinks.
=cut
sub prepareView {
my $self = shift;
$self->addHeaderLinks;
return $self->next::method(@_);
}
#-------------------------------------------------------------------
=head2 addHeaderLinks ()
Add RSS, Atom, or RDF links in the HEAD block of the Asset, depending
on how the Asset has configured feedHeaderLinks.
=cut
sub addHeaderLinks {
my $self = shift;
my $style = $self->session->style;

2
lib/WebGUI/Form/Date.pm
View file

@ -221,7 +221,7 @@ sub toHtml {
|| !$self->get("value")
|| $self->get("value") =~ m/^\d+$/) {
# Epoch format
$value = $self->set("value",$self->session->datetime->epochToSet($self->getOriginalValue));
$value = $self->session->datetime->epochToSet($self->getOriginalValue);
}
else {
# MySQL format

8
lib/WebGUI/Form/HTMLArea.pm
View file

@ -132,6 +132,14 @@ sub getValue {
return WebGUI::HTML::cleanSegment($self->SUPER::getValue(@_));
}
#-------------------------------------------------------------------
=head2 getValueAsHtml ( )
Calls getValueAsHtml from WebGUI::Form::Control
=cut
sub getValueAsHtml {
my $self = shift;
return $self->WebGUI::Form::Control::getValueAsHtml(@_);

2
lib/WebGUI/Group.pm
View file

@ -256,7 +256,7 @@ sub dateCreated {
=head2 delete ( )
Deletes this group and all references to it.
Deletes this group from the group related tables in the database and calls clearCaches.
=cut

4
lib/WebGUI/Help/Asset_Thingy.pm
View file

@ -221,7 +221,11 @@ our $HELP = {
{ 'name' => 'searchResult_id' },
{ 'name' => 'searchResult_view_url' },
{ 'name' => 'searchResult_edit_icon' },
{ 'name' => 'searchResult_edit_url' },
{ 'name' => 'searchResult_delete_icon' },
{ 'name' => 'searchResult_delete_url' },
{ 'name' => 'searchResult_copy_icon' },
{ 'name' => 'searchResult_copy_url' },
{ 'name' => 'searchResult_field_loop',
'variables' => [
{ 'name' => 'field_id' },

8
lib/WebGUI/SQL.pm
View file

@ -503,9 +503,11 @@ Disconnects from the database. And destroys the object.
=cut
sub disconnect {
my $self = shift;
$self->dbh->disconnect;
undef $self;
my $self = shift;
my $dbh = delete $self->{_dbh};
if ($dbh) {
$dbh->disconnect;
}
}

11
lib/WebGUI/i18n/English/Asset_Matrix.pm
View file

@ -807,6 +807,17 @@ selectBox.</p>|
message => q|Matrix Fieldtype|,
},
'too many message' => {
lastUpdated => 0,
message => q|You tried to compare more than your maximum number of listings.|,
context => q|A message shown to the user when they have selected too many listings to compare.|,
},
'too few message' => {
lastUpdated => 0,
message => q|You tried to compare only one listing. If you want to view just one listing, click on its name.|,
context => q|A message shown to the user when they have selected only one listing to compare.|,
}
};
1;

46
lib/WebGUI/i18n/English/Asset_Survey.pm
View file

@ -67,6 +67,10 @@ our $I18N = {
message => q|Delete|,
lastUpdated => 1224686319
},
'warnings' => {
message => q|Warnings|,
lastUpdated => 0
},
'section number' => {
message => q|Section Number:|,
lastUpdated => 1224686319
@ -251,9 +255,9 @@ our $I18N = {
lastUpdated => 1224686319
},
'show text in button description' => {
message => q|Select if the buttons of a multiple choice question display the answer values or not.|,
message => q|By default multiple choice answer buttons show the answer text above each button. Change this to have the text appear inside of the buttons.|,
context => q|Description of the 'show text in button' field, used as hoverhelp in the edit question dialog.|,
lastUpdated => 0
lastUpdated => 1239251986
},
'allow comment' => {
message => q|Allow comment:|,
@ -300,14 +304,14 @@ our $I18N = {
context => q|Description of the 'required' field, used as hoverhelp in the edit question dialog.|,
lastUpdated => 0
},
'question value' => {
message => q|Question value:|,
'question score' => {
message => q|Question score:|,
lastUpdated => 1224686319
},
'question value description' => {
message => q|Enter a value for this question.|,
'question score description' => {
message => q|Default score to use for answers in this question that don't have an answer score value set.|,
context => q|Description of the 'question value' field, used as hoverhelp in the edit question dialog.|,
lastUpdated => 0
lastUpdated => 1239255403
},
'please enter answer information' => {
message => q|Please enter answer information:|,
@ -333,13 +337,13 @@ our $I18N = {
lastUpdated => 0
},
'recorded answer' => {
message => q|Answer title:|,
message => q|Recorded Answer:|,
lastUpdated => 1224686319
},
'recorded answer description' => {
message => q|Text to display inside multiple-choice answer buttons (only if 'Show text in button' is enabled for this question).|,
message => q|Determines what gets recorded as the response value if this answer is selected. Allows you to 'recode' recorded responses, e.g. 'Yes' could be recorded as '1' and 'No' as '0'. Relevant only for Multiple Choice questions (other question types record the input actually entered by the user: free text, selected date, etc..).|,
context => q|Description of the 'recorded answer' field, used as hoverhelp in the edit answer dialog.|,
lastUpdated => 0
lastUpdated => 1239251436
},
'jump to' => {
message => q|Jump to:|,
@ -355,9 +359,9 @@ our $I18N = {
lastUpdated => 0
},
'jump expression description' => {
message => q|An expression used to control complex branching based user responses to previous questions. A branch expression is made up of a list of rules, one per line, along with a branch target for each rule. |,
message => q|An expression used to control complex branching based user responses to previous questions. Ignored unless enableSurveyExpressionEngine enabled in your site config file.|,
context => q|Description of the 'jump expression' field, used as hoverhelp in the edit answer dialog.|,
lastUpdated => 0
lastUpdated => 1239259550
},
'text answer' => {
message => q|TextArea|,
@ -416,14 +420,14 @@ our $I18N = {
context => q|Description of the 'verbatim' field, used as hoverhelp in the edit answer dialog.|,
lastUpdated => 0
},
'answer value' => {
message => q|Answer value:|,
lastUpdated => 1224686319
'answer score' => {
message => q|Answer score:|,
lastUpdated => 1239251986
},
'answer value description' => {
message => q|Assign a numeric scores to this answers. Used in question scoring and jump expressions.|,
context => q|Description of the 'answer value' field, used as hoverhelp in the edit answer dialog.|,
lastUpdated => 0
'answer score description' => {
message => q|Assign a numeric score to this answer. If blank, the question score value will used instead. Used in question scoring and jump expressions.|,
context => q|Description of the 'answer score' field, used as hoverhelp in the edit answer dialog.|,
lastUpdated => 1239251986
},
'checked' => {
message => q|Checked|,
@ -1282,7 +1286,7 @@ section/answer.|,
},
'textInButton' => {
message => q|A boolean indicating whether the buttons for answers to multiple choice questions should display the answer's text.|,
message => q|A boolean indicating whether the buttons for answers to multiple choice questions should display the answer's text inside or above.|,
context => q|Description of a template variable for a template Help page.|,
lastUpdated => 0,
},
@ -1318,7 +1322,7 @@ section/answer.|,
},
'recordedAnswer' => {
message => q|The value that gets recorded for this answer in the database.|,
message => q|Determines what gets recorded as the response value if this answer is selected. Allows you to 'recode' recorded responses, e.g. 'Yes' could be recorded as '1' and 'No' as '0'. Relevant only for Multiple Choice questions (other question types record the input actually entered by the user: free text, selected date, etc..).|,
context => q|Description of a template variable for a template Help page.|,
lastUpdated => 0,
},

23
lib/WebGUI/i18n/English/Asset_Thingy.pm
View file

@ -1013,12 +1013,35 @@ search has been done.|,
context => q|Description of a tmpl_var for the template help.|,
},
'searchResult_edit_url' => {
message => q|Url to the edit screen of this search result.|,
lastUpdated => 1104630516,
context => q|Description of a tmpl_var for the template help.|,
},
'searchResult_delete_icon' => {
message => q|Delete icon to delete this search result.|,
lastUpdated => 1104630516,
context => q|Description of a tmpl_var for the template help.|,
},
'searchResult_delete_url' => {
message => q|Url to delete this search result.|,
lastUpdated => 1104630516,
context => q|Description of a tmpl_var for the template help.|,
},
'searchResult_copy_icon' => {
message => q|Copy icon to copy this search result.|,
lastUpdated => 1104630516,
context => q|Description of a tmpl_var for the template help.|,
},
'searchResult_copy_url' => {
message => q|Url to copy this search result.|,
lastUpdated => 1104630516,
},
'searchResult_field_loop' => {
message => q|A loop containing the fields that are to be displayed for this search result.|,
lastUpdated => 1104630516,