Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Added command used to find epass bug
  • Loading branch information
patspam committed Dec 1, 2009
1 parent 7a75b3a commit a0912af
Showing 1 changed file with 279 additions and 0 deletions.
279 changes: 279 additions & 0 deletions lib/WGDev/Command/Bug.pm
@@ -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

0 comments on commit a0912af

Please sign in to comment.