forked from haarg/wgdev
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Browse files
Browse the repository at this point in the history
Added command used to find epass bug
- Loading branch information
Showing
1 changed file
with
279 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,279 @@ | ||
package WGDev::Command::Bug; | ||
use strict; | ||
use warnings; | ||
use 5.008008; | ||
|
||
our $VERSION = '0.1.0'; | ||
|
||
use WGDev::Command::Base; | ||
BEGIN { our @ISA = qw(WGDev::Command::Base) } | ||
|
||
use lib '/projects/WebFlow/lib'; | ||
use NETC; | ||
|
||
sub process2 { | ||
my $self = shift; | ||
my $wgd = $self->wgd; | ||
my $session = $wgd->session; | ||
|
||
for my $username qw(test1 test2) { | ||
if (my $u = WebGUI::User->newByUsername($session, $username)) { | ||
$u->delete; | ||
} | ||
} | ||
|
||
my $user = WebGUI::User->new($session, 'new'); | ||
$user->profileField('username', 'test1'); | ||
my $userId = $user->userId; | ||
|
||
my $user2 = WebGUI::User->new($session, 'new'); | ||
$user2->profileField('username', 'test2'); | ||
my $userId2 = $user2->userId; | ||
|
||
# Remove existing responses | ||
$session->db->write( 'delete from Survey_response where userId = ? or userId = ?', [ $userId, $userId2 ] ); | ||
|
||
# Start a response | ||
{ | ||
my $pre = WebGUI::Asset->new( $session, NETC::ASSET_PRE_ASSESSMENT ); | ||
my $pre_responseId = $pre->responseId( { userId => $userId } ); | ||
|
||
my $pre_rJSON = $pre->responseJSON; | ||
$pre_rJSON->processGoto('S_DEM3'); | ||
$pre_rJSON->recordResponses({ | ||
'6-0-0' => '1981', | ||
}); | ||
$pre_rJSON->recordResponses({ | ||
'7-0-0' => 'Male', | ||
}); | ||
$pre_rJSON->recordResponses({ | ||
'8-0-0' => 'Married', | ||
'8-1-0' => 'Australia', | ||
'8-2-0' => 'Australia', | ||
}); | ||
|
||
print Data::Dumper::Dumper($pre_rJSON->responses); | ||
print Data::Dumper::Dumper($pre_rJSON->tags); | ||
|
||
$pre->persistResponseJSON; | ||
$pre->surveyEnd(); | ||
} | ||
|
||
# Start another response as a different user | ||
{ | ||
my $pre = WebGUI::Asset->new( $session, NETC::ASSET_PRE_ASSESSMENT ); | ||
my $pre_responseId = $pre->responseId( { userId => $userId2 } ); | ||
|
||
my $pre_rJSON = $pre->responseJSON; | ||
$pre_rJSON->processGoto('S_DEM3'); | ||
$pre_rJSON->recordResponses({ | ||
'6-0-0' => '1982', | ||
}); | ||
$pre_rJSON->recordResponses({ | ||
'7-0-1' => 'Female', | ||
}); | ||
$pre_rJSON->recordResponses({ | ||
'8-0-0' => 'Married', | ||
'8-1-0' => 'Australia', | ||
'8-2-0' => 'Australia', | ||
}); | ||
|
||
print Data::Dumper::Dumper($pre_rJSON->responses); | ||
print Data::Dumper::Dumper($pre_rJSON->tags); | ||
|
||
$pre->persistResponseJSON; | ||
$pre->surveyEnd(); | ||
} | ||
|
||
# Start an ePASS response as the second user | ||
{ | ||
my $epass = WebGUI::Asset->new( $session, NETC::ASSET_EPASS ); | ||
$session->user( { userId => $userId2 } ); | ||
my $epass_responseId = $epass->responseId( { userId => $userId2 } ); | ||
|
||
my $epass_rJSON = $epass->responseJSON; | ||
|
||
print Data::Dumper::Dumper($epass_rJSON->responses); | ||
print Data::Dumper::Dumper($epass_rJSON->tags); | ||
|
||
$epass->persistResponseJSON; | ||
$epass->surveyEnd(); | ||
} | ||
|
||
# Start an ePASS response as the first user | ||
{ | ||
my $epass = WebGUI::Asset->new( $session, NETC::ASSET_EPASS ); | ||
$session->user( { userId => $userId } ); | ||
my $epass_responseId = $epass->responseId( { userId => $userId } ); | ||
|
||
my $epass_rJSON = $epass->responseJSON; | ||
|
||
print Data::Dumper::Dumper($epass_rJSON->responses); | ||
print Data::Dumper::Dumper($epass_rJSON->tags); | ||
|
||
$epass->persistResponseJSON; | ||
$epass->surveyEnd(); | ||
} | ||
|
||
|
||
$user->delete; | ||
$user2->delete; | ||
} | ||
|
||
sub process { | ||
my $self = shift; | ||
my $wgd = $self->wgd; | ||
my $session = $wgd->session; | ||
|
||
use Tie::IxHash; | ||
tie my %epass, 'Tie::IxHash'; | ||
%epass | ||
= $session->db->buildHash( <<END_SQL, [ NETC::ASSET_EPASS, NETC::GROUP_CONSUMERS, NETC::GROUP_DEMO ] ); | ||
select Survey_responseId, userId | ||
from Survey_response r | ||
where assetId = ? | ||
and userId in (select userId from groupings where groupId = ?) | ||
and userId not in (select userId from groupings where groupId = ?) | ||
order by startDate asc | ||
END_SQL | ||
my %username = $session->db->buildHash('select userId, username from users'); | ||
|
||
require WebGUI::Asset::Wobject::Survey; | ||
for my $epass_responseId ( keys %epass ) { | ||
my $epass = WebGUI::Asset::Wobject::Survey->newByResponseId( $session, $epass_responseId ); | ||
my $epass_tags = $epass->responseJSON->tags; | ||
|
||
# print Data::Dumper::Dumper($epass_tags); | ||
|
||
my $userId = $epass{$epass_responseId} or next; | ||
my @pre_responseIds = $session->db->buildArray( | ||
'select Survey_responseId from Survey_response where userId = ? and assetId = ? and (isComplete = 1 or isComplete = -1) order by endDate desc', | ||
[ $userId, NETC::ASSET_PRE_ASSESSMENT ] | ||
); | ||
my $warn = ''; | ||
if ( @pre_responseIds > 1 ) { | ||
$warn .= "Count: " . @pre_responseIds . "\n"; | ||
} | ||
if ( !@pre_responseIds || !$pre_responseIds[0] ) { | ||
print "!No pre! [$username{$userId}]\n"; | ||
next; | ||
} | ||
|
||
my $pre_responseId = $pre_responseIds[0]; | ||
my $pre = WebGUI::Asset::Wobject::Survey->newByResponseId( $session, $pre_responseId ); | ||
my $pre_tags = $pre->responseJSON->tags; | ||
|
||
if (!$pre_tags->{DOB}) { | ||
$warn .= "No DOB\n"; | ||
} | ||
|
||
# print Data::Dumper::Dumper($pre_tags); | ||
my $diff = ''; | ||
for my $field qw(AUSTRALIAN_RESIDENT DOB MALE FEMALE) { | ||
no warnings; | ||
if ($pre_tags->{$field} && $pre_tags->{$field} ne $epass_tags->{$field}) { | ||
if ($epass_tags->{$field}) { | ||
$diff .= "Got $field = '$epass_tags->{$field}', Expected '$pre_tags->{$field}'\n"; | ||
} else { | ||
$diff .= "Expected $field\n"; | ||
} | ||
} | ||
if (!$pre_tags->{$field} && $epass_tags->{$field}) { | ||
$diff .= "Did Not Expect $field\n"; | ||
} | ||
} | ||
if ( $diff ) { | ||
|
||
my ( $preStartDate, $preEndDate ) | ||
= $session->db->quickArray( | ||
'select startDate, endDate from Survey_response where Survey_responseId = ?', | ||
[$pre_responseId] ); | ||
( $preStartDate, $preEndDate ) | ||
= map { $_ && DateTime->from_epoch( epoch => $_ ) } ( $preStartDate, $preEndDate ); | ||
# print "Pre:\n Start:\t $preStartDate\n End:\t $preEndDate\n"; | ||
|
||
my ( $epassStartDate, $epassEndDate ) | ||
= $session->db->quickArray( | ||
'select startDate, endDate from Survey_response where Survey_responseId = ?', | ||
[$epass_responseId] ); | ||
( $epassStartDate, $epassEndDate ) | ||
= map { $_ && DateTime->from_epoch( epoch => $_ ) } ( $epassStartDate, $epassEndDate ); | ||
# print "ePASS:\n Start:\t $epassStartDate\n End:\t $epassEndDate\n"; | ||
|
||
#print "[$username{$userId} $pre_responseId $epassStartDate]\n"; | ||
print "$epass_responseId\n"; | ||
|
||
# my ($epassStartDate, $epassEndDate) = $session->db->quickArray('select startDate, endDate from Survey_response where Survey_responseId = ?', [$epass->getId]); | ||
# print "ePASS\tStart: " . DateTime->from_epoch( epoch => $epassStartDate ); | ||
# print " End: " . DateTime->from_epoch( epoch => $epassEndDate ) . "\n"; | ||
#print $warn if $warn; | ||
# my $diag = Test::Deep::deep_diag($stack); | ||
# $diag =~ s/^.*\n//; | ||
#print "$diff\n"; | ||
} | ||
} | ||
return 1; | ||
} | ||
|
||
1; | ||
|
||
__END__ | ||
=head1 NAME | ||
WGDev::Command::Bug - Manipulate Survey instances | ||
=head1 SYNOPSIS | ||
wgd survey [--check] [--fix] [--variables] [--dump] [--stats] [--branching] [--graph] [--setYesNo] | ||
=head1 DESCRIPTION | ||
Various utilities for Survey instances (dump structure, visualise, etc..). | ||
=head1 OPTIONS | ||
=over 8 | ||
=item C<--check> C<--fix> | ||
Check for corruption, and optionally try to fix it. | ||
=item C<--variables> | ||
Set Section and Question variables from title text | ||
=item C<--dump> | ||
Dump Survey structure | ||
=item C<--stats> | ||
Show Survey stats | ||
=item C<--branching> | ||
Dumps brief outline of survey branching | ||
=item C<--graph> | ||
Generates a graph visualisation to survey.svg using GraphViz. | ||
=item C<--setYesNo> | ||
Updates YesNo type questions to more sensible defaults. | ||
=back | ||
=head1 AUTHOR | ||
Patrick Donelan <pat@patspam.com> | ||
=head1 LICENSE | ||
Copyright (c) Patrick Donelan. All rights reserved. | ||
This library is free software; you can redistribute it and/or modify it under | ||
the same terms as Perl itself. | ||
=cut |