Matthew Raymer
4 months ago
98 changed files with 47 additions and 140666 deletions
@ -1,2 +1,2 @@ |
|||||
*~ |
*~ |
||||
*/log |
sess.* |
||||
|
|||||
@ -1,287 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
|
|
||||
# Copyright 2011 Hank Ivy |
|
||||
|
|
||||
# Package to load data into memory for multiple usage. |
|
||||
# use strict ; |
|
||||
# use warnings ; |
|
||||
# require 'sitecfg.pl' ; |
|
||||
|
|
||||
package InMem ; |
|
||||
use Exporter () ; |
|
||||
@ISA = qw(Exporter) ; |
|
||||
@EXPORT = qw(InsertQuesResp InsertQuesComment $GlobalData) ; |
|
||||
@EXPORT_OK = qw( ) ; |
|
||||
|
|
||||
local $GlobalData = {} ; |
|
||||
my $ValidClientChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my $ValidCandidateChar = "0\-9a\-zA\-Z\\_\\- " ; |
|
||||
my $ValidTestIDChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my %ValidTestTypes = (complete => 1, pending => 1, inprog => 1 ) ; |
|
||||
my $InMem_Debug = 0 ; |
|
||||
|
|
||||
unless ($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
warn "Init. GlobalData" if ($InMem_Debug) ; |
|
||||
} |
|
||||
|
|
||||
sub ValidateClientStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Client exists. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
if ((length $ClientID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($ClientID =~ m/^[${ValidClientChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateTestIDStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the TestID exists. |
|
||||
# Parameters |
|
||||
# $TestID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($TestID ) = @_ ; |
|
||||
if ((length $TestID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($TestID =~ m/^[${ValidTestIDChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateCandidateStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Candidate exists. |
|
||||
# Parameters |
|
||||
# $CandidateID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($CandidateID ) = @_ ; |
|
||||
if ((length $CandidateID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidQId { |
|
||||
# Validate the scalar as a numeric greater than 0. |
|
||||
# A positive result does not mean the Question ID exists. |
|
||||
# Parameters |
|
||||
# $QuesId - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($QuesId ) = @_ ; |
|
||||
unless ($QuesId) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId =~ m/^\d+$/ ) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId > 0) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateClientSkeleton { |
|
||||
# Create a very minimal data structure for a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
unless ($ClientID) { |
|
||||
die "Error: CreateClientSkeleton called with an empty ClientID" ; |
|
||||
} |
|
||||
unless (&ValidateClientStr($ClientID)) { |
|
||||
die "Error: CreateClientSkeleton called with an invalid ClientID character." |
|
||||
} |
|
||||
unless($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
} |
|
||||
unless($GlobalData -> {'CLIENTS'} -> {$ClientID}) { |
|
||||
warn "Initialize $ClientID Client" if ($InMem_Debug) ; |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCandidateSkeleton { |
|
||||
# Create a very minimal data structure for a candidate associated with a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
my ($ClientID, $CandidateID ) = @_ ; |
|
||||
unless ( &CreateClientSkeleton($ClientID) ) { |
|
||||
warn "Fail $ClientID, $CandidateID CreateCandidateSkeleton" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($CandidateID) { |
|
||||
die "Error: CreateCandidateSkeleton called with an empty CandidateID" ; |
|
||||
} |
|
||||
unless ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
die "Error: CreateCandidateSkeleton called with an invalid CandidateID character." |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} ) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID}) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub GetClientsInMem { |
|
||||
# Return an array of the Client Names in Memory. |
|
||||
my @Clients ; |
|
||||
if ($GlobalData and $GlobalData -> {'CLIENTS'}) { |
|
||||
@Clients = keys %{$GlobalData -> {'CLIENTS'}} ; |
|
||||
} |
|
||||
return @Clients ; |
|
||||
} |
|
||||
|
|
||||
sub ImportAllClientIDs { |
|
||||
# Populate the data structure for all clients. |
|
||||
# Parameters - No input parms. |
|
||||
# Return 0 if there is a problem, 1 if all is OK. |
|
||||
my $ClientFile = $main::PATHS{'dataroot'} . $main::pathsep . "clients.dat" ; |
|
||||
my $line_cnt = 0 ; |
|
||||
my @field_ids = () ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestSkel { |
|
||||
# Create a very minimal data structure for a test taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID) = @_ ; |
|
||||
unless ( &CreateCandidateSkeleton($ClientID, $CandidateID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidateTestIDStr ($TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeSkel { |
|
||||
# Create a very minimal data structure for a test type taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType) = @_ ; |
|
||||
unless (&CreateCanTestSkel($ClientID, $CandidateID, $TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($ValidTestTypes{$TestType}) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeQIdSkel { |
|
||||
# Create a very minimal data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID) = @_ ; |
|
||||
unless (&CreateCanTestTypeSkel($ClientID, $CandidateID, $TestID, $TestType)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidQId($QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType, $QuesID QuesID" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesComment { |
|
||||
# Place a Comment in a data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Comment - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Comment) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Comment) { |
|
||||
$Comment = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Comment'} = $Comment ; |
|
||||
warn "Add Comment CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $Comment X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesResp { |
|
||||
# Place a Text Response answer for a Question in a test taken in a data structure. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Resp - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Resp) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Resp) { |
|
||||
$Resp = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Resp'} = $Resp ; |
|
||||
warn "Add Response CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $resp X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
1 ; # End of a library perl file. |
|
||||
|
|
||||
@ -1,287 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
|
|
||||
# Copyright 2011 Hank Ivy |
|
||||
|
|
||||
# Package to load data into memory for multiple usage. |
|
||||
# use strict ; |
|
||||
# use warnings ; |
|
||||
# require 'sitecfg.pl' ; |
|
||||
|
|
||||
package InMem ; |
|
||||
use Exporter () ; |
|
||||
@ISA = qw(Exporter) ; |
|
||||
@EXPORT = qw(InsertQuesResp InsertQuesComment $GlobalData) ; |
|
||||
@EXPORT_OK = qw( ) ; |
|
||||
|
|
||||
local $GlobalData = {} ; |
|
||||
my $ValidClientChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my $ValidCandidateChar = "0\-9a\-zA\-Z\\_\\-\@\. " ; |
|
||||
my $ValidTestIDChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my %ValidTestTypes = (complete => 1, pending => 1, inprog => 1 ) ; |
|
||||
my $InMem_Debug = 0 ; |
|
||||
|
|
||||
unless ($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
warn "Init. GlobalData" if ($InMem_Debug) ; |
|
||||
} |
|
||||
|
|
||||
sub ValidateClientStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Client exists. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
if ((length $ClientID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($ClientID =~ m/^[${ValidClientChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateTestIDStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the TestID exists. |
|
||||
# Parameters |
|
||||
# $TestID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($TestID ) = @_ ; |
|
||||
if ((length $TestID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($TestID =~ m/^[${ValidTestIDChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateCandidateStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Candidate exists. |
|
||||
# Parameters |
|
||||
# $CandidateID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($CandidateID ) = @_ ; |
|
||||
if ((length $CandidateID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidQId { |
|
||||
# Validate the scalar as a numeric greater than 0. |
|
||||
# A positive result does not mean the Question ID exists. |
|
||||
# Parameters |
|
||||
# $QuesId - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($QuesId ) = @_ ; |
|
||||
unless ($QuesId) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId =~ m/^\d+$/ ) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId > 0) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateClientSkeleton { |
|
||||
# Create a very minimal data structure for a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
unless ($ClientID) { |
|
||||
die "Error: CreateClientSkeleton called with an empty ClientID" ; |
|
||||
} |
|
||||
unless (&ValidateClientStr($ClientID)) { |
|
||||
die "Error: CreateClientSkeleton called with an invalid ClientID character." |
|
||||
} |
|
||||
unless($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
} |
|
||||
unless($GlobalData -> {'CLIENTS'} -> {$ClientID}) { |
|
||||
warn "Initialize $ClientID Client" if ($InMem_Debug) ; |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCandidateSkeleton { |
|
||||
# Create a very minimal data structure for a candidate associated with a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
my ($ClientID, $CandidateID ) = @_ ; |
|
||||
unless ( &CreateClientSkeleton($ClientID) ) { |
|
||||
warn "Fail $ClientID, $CandidateID CreateCandidateSkeleton" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($CandidateID) { |
|
||||
die "Error: CreateCandidateSkeleton called with an empty CandidateID" ; |
|
||||
} |
|
||||
unless ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
die "Error: CreateCandidateSkeleton called with an invalid CandidateID character" . $CandidateID . "." ; |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} ) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID}) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub GetClientsInMem { |
|
||||
# Return an array of the Client Names in Memory. |
|
||||
my @Clients ; |
|
||||
if ($GlobalData and $GlobalData -> {'CLIENTS'}) { |
|
||||
@Clients = keys %{$GlobalData -> {'CLIENTS'}} ; |
|
||||
} |
|
||||
return @Clients ; |
|
||||
} |
|
||||
|
|
||||
sub ImportAllClientIDs { |
|
||||
# Populate the data structure for all clients. |
|
||||
# Parameters - No input parms. |
|
||||
# Return 0 if there is a problem, 1 if all is OK. |
|
||||
my $ClientFile = $main::PATHS{'dataroot'} . $main::pathsep . "clients.dat" ; |
|
||||
my $line_cnt = 0 ; |
|
||||
my @field_ids = () ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestSkel { |
|
||||
# Create a very minimal data structure for a test taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID) = @_ ; |
|
||||
unless ( &CreateCandidateSkeleton($ClientID, $CandidateID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidateTestIDStr ($TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeSkel { |
|
||||
# Create a very minimal data structure for a test type taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType) = @_ ; |
|
||||
unless (&CreateCanTestSkel($ClientID, $CandidateID, $TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($ValidTestTypes{$TestType}) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeQIdSkel { |
|
||||
# Create a very minimal data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID) = @_ ; |
|
||||
unless (&CreateCanTestTypeSkel($ClientID, $CandidateID, $TestID, $TestType)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidQId($QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType, $QuesID QuesID" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesComment { |
|
||||
# Place a Comment in a data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Comment - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Comment) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Comment) { |
|
||||
$Comment = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Comment'} = $Comment ; |
|
||||
warn "Add Comment CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $Comment X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesResp { |
|
||||
# Place a Text Response answer for a Question in a test taken in a data structure. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Resp - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Resp) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Resp) { |
|
||||
$Resp = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Resp'} = $Resp ; |
|
||||
# warn "Add Response CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $resp X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
1 ; # End of a library perl file. |
|
||||
|
|
||||
@ -1,287 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
|
|
||||
# Copyright 2011 Hank Ivy |
|
||||
|
|
||||
# Package to load data into memory for multiple usage. |
|
||||
# use strict ; |
|
||||
# use warnings ; |
|
||||
# require 'sitecfg.pl' ; |
|
||||
|
|
||||
package InMem ; |
|
||||
use Exporter () ; |
|
||||
@ISA = qw(Exporter) ; |
|
||||
@EXPORT = qw(InsertQuesResp InsertQuesComment $GlobalData) ; |
|
||||
@EXPORT_OK = qw( ) ; |
|
||||
|
|
||||
local $GlobalData = {} ; |
|
||||
my $ValidClientChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my $ValidCandidateChar = "0\-9a\-zA\-Z\\_\\-\@\., " ; |
|
||||
my $ValidTestIDChar = "0\-9a\-zA\-Z\_\-" ; |
|
||||
my %ValidTestTypes = (complete => 1, pending => 1, inprog => 1 ) ; |
|
||||
my $InMem_Debug = 0 ; |
|
||||
|
|
||||
unless ($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
warn "Init. GlobalData" if ($InMem_Debug) ; |
|
||||
} |
|
||||
|
|
||||
sub ValidateClientStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Client exists. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
if ((length $ClientID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($ClientID =~ m/^[${ValidClientChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateTestIDStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the TestID exists. |
|
||||
# Parameters |
|
||||
# $TestID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($TestID ) = @_ ; |
|
||||
if ((length $TestID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($TestID =~ m/^[${ValidTestIDChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidateCandidateStr { |
|
||||
# Validate just the characters in the str. |
|
||||
# A positive result does not mean the Candidate exists. |
|
||||
# Parameters |
|
||||
# $CandidateID - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($CandidateID ) = @_ ; |
|
||||
if ((length $CandidateID) == 0) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
if ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
return 1 ; |
|
||||
} else { |
|
||||
return 0 ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub ValidQId { |
|
||||
# Validate the scalar as a numeric greater than 0. |
|
||||
# A positive result does not mean the Question ID exists. |
|
||||
# Parameters |
|
||||
# $QuesId - Character String. |
|
||||
# Returns 1 for a valid string, 0 for invalid. |
|
||||
my ($QuesId ) = @_ ; |
|
||||
unless ($QuesId) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId =~ m/^\d+$/ ) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($QuesId > 0) { |
|
||||
warn "Bad $QuesId QuesId" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateClientSkeleton { |
|
||||
# Create a very minimal data structure for a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
my ($ClientID ) = @_ ; |
|
||||
unless ($ClientID) { |
|
||||
die "Error: CreateClientSkeleton called with an empty ClientID" ; |
|
||||
} |
|
||||
unless (&ValidateClientStr($ClientID)) { |
|
||||
die "Error: CreateClientSkeleton called with an invalid ClientID character." |
|
||||
} |
|
||||
unless($GlobalData) { |
|
||||
$GlobalData = {'CLIENTS' => {}} ; |
|
||||
} |
|
||||
unless($GlobalData -> {'CLIENTS'} -> {$ClientID}) { |
|
||||
warn "Initialize $ClientID Client" if ($InMem_Debug) ; |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCandidateSkeleton { |
|
||||
# Create a very minimal data structure for a candidate associated with a client. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
my ($ClientID, $CandidateID ) = @_ ; |
|
||||
unless ( &CreateClientSkeleton($ClientID) ) { |
|
||||
warn "Fail $ClientID, $CandidateID CreateCandidateSkeleton" if ($InMem_Debug) ; |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($CandidateID) { |
|
||||
die "Error: CreateCandidateSkeleton called with an empty CandidateID" ; |
|
||||
} |
|
||||
unless ($CandidateID =~ m/^[${ValidCandidateChar}]+$/o ) { |
|
||||
die "Error: CreateCandidateSkeleton called with an invalid CandidateID character" . $CandidateID . "." ; |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} ) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
unless ($GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID}) { |
|
||||
$GlobalData -> {'CLIENTS'} -> {$ClientID} -> {'CANDIDATES'} -> {$CandidateID} = {} ; |
|
||||
warn "Initialize $CandidateID CandidateID" if ($InMem_Debug) ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub GetClientsInMem { |
|
||||
# Return an array of the Client Names in Memory. |
|
||||
my @Clients ; |
|
||||
if ($GlobalData and $GlobalData -> {'CLIENTS'}) { |
|
||||
@Clients = keys %{$GlobalData -> {'CLIENTS'}} ; |
|
||||
} |
|
||||
return @Clients ; |
|
||||
} |
|
||||
|
|
||||
sub ImportAllClientIDs { |
|
||||
# Populate the data structure for all clients. |
|
||||
# Parameters - No input parms. |
|
||||
# Return 0 if there is a problem, 1 if all is OK. |
|
||||
my $ClientFile = $main::PATHS{'dataroot'} . $main::pathsep . "clients.dat" ; |
|
||||
my $line_cnt = 0 ; |
|
||||
my @field_ids = () ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestSkel { |
|
||||
# Create a very minimal data structure for a test taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID) = @_ ; |
|
||||
unless ( &CreateCandidateSkeleton($ClientID, $CandidateID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidateTestIDStr ($TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID CandidateID Tests" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeSkel { |
|
||||
# Create a very minimal data structure for a test type taken by a candidate. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType) = @_ ; |
|
||||
unless (&CreateCanTestSkel($ClientID, $CandidateID, $TestID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($ValidTestTypes{$TestType}) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID} = {} ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType TestType" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub CreateCanTestTypeQIdSkel { |
|
||||
# Create a very minimal data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID) = @_ ; |
|
||||
unless (&CreateCanTestTypeSkel($ClientID, $CandidateID, $TestID, $TestType)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless (&ValidQId($QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
unless ($GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} ) { |
|
||||
warn "Initialize $ClientID, $CandidateID, $TestType, $QuesID QuesID" if ($InMem_Debug) ; |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID} = {} ; |
|
||||
} |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesComment { |
|
||||
# Place a Comment in a data structure for a Question in a test taken. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Comment - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Comment) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Comment) { |
|
||||
$Comment = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Comment'} = $Comment ; |
|
||||
warn "Add Comment CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $Comment X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
sub InsertQuesResp { |
|
||||
# Place a Text Response answer for a Question in a test taken in a data structure. |
|
||||
# Parameters |
|
||||
# $ClientID - Character String. |
|
||||
# $CandidateID - Character String. |
|
||||
# $TestID - Character String. |
|
||||
# $TestType - Character String, limited values. |
|
||||
# $QuesID - a one based integer. |
|
||||
# $Resp - A string. |
|
||||
# Return 1 for success, 0 for failure. |
|
||||
my ($ClientID, $CandidateID, $TestID, $TestType, $QuesID, $Resp) = @_ ; |
|
||||
unless (&CreateCanTestTypeQIdSkel($ClientID, $CandidateID, $TestID, $TestType, $QuesID)) { |
|
||||
return 0 ; |
|
||||
} |
|
||||
# Any Character string, even an empty string is valid. |
|
||||
unless ($Resp) { |
|
||||
$Resp = "" ; |
|
||||
} |
|
||||
$GlobalData->{'CLIENTS'}->{$ClientID}->{'CANDIDATES'}->{$CandidateID}->{'Tests'}->{$TestID}->{$TestType}->{$QuesID}->{'Resp'} = $Resp ; |
|
||||
# warn "Add Response CLI $ClientID User $CandidateID Tst $TestID Type $TestType QID $QuesID Text $resp X" ; |
|
||||
return 1 ; |
|
||||
} |
|
||||
|
|
||||
1 ; # End of a library perl file. |
|
||||
|
|
||||
File diff suppressed because it is too large
@ -1,503 +0,0 @@ |
|||||
package IntegroLib; |
|
||||
|
|
||||
# A collection of functions used for custom reports for Integro. |
|
||||
# Most data processing functions. |
|
||||
# |
|
||||
# $Id: IntegroLib.pm,v 1.5 2005/10/31 17:03:34 ddoughty Exp $ |
|
||||
|
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
|
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot ); |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
|
|
||||
require Exporter; |
|
||||
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); |
|
||||
@ISA = qw(Exporter); |
|
||||
# Items to export into callers namespace by default. Note: do not export |
|
||||
# names by default without a very good reason. Use EXPORT_OK instead. |
|
||||
# Do not simply export all your public functions/methods/constants. |
|
||||
@EXPORT = qw(get_survey_results CommEffectData TrustLevelData ValuesData diversityData KindsOfPeopleData); |
|
||||
@EXPORT_OK = qw(); |
|
||||
$VERSION = '0.01'; |
|
||||
|
|
||||
sub get_survey_results { |
|
||||
my ($client,$user,$test) = @_; |
|
||||
&main::get_test_sequence_for_reports($client,$user,$test); |
|
||||
#print STDERR Dumper(\%SUBTEST_RESPONSES,\%SUBTEST_QUESTIONS); |
|
||||
my (@answers,$i,@comments,@responses); |
|
||||
foreach (split(/\&/,$main::SUBTEST_RESPONSES{2})) { |
|
||||
my ($response,$comment) = split(/::/,$_); |
|
||||
push @responses, $response; |
|
||||
push @comments, $comment; |
|
||||
} |
|
||||
for ($i = 1; $i<=69; $i++) { |
|
||||
($responses[$i] =~ /^\D*(\d+)/); |
|
||||
$answers[$i] = $1; |
|
||||
# Also need to get comments |
|
||||
} |
|
||||
if ($main::SUBTEST_QUESTIONS{2} =~ /\.057/) { |
|
||||
($responses[57] =~ /^\D*(\d+)/); |
|
||||
$answers[57] = $1; |
|
||||
} else { |
|
||||
# Question 57 is suppressed in this survey |
|
||||
# Shift the last two questions to their |
|
||||
# correct position, and flag 57 |
|
||||
$comments[60] = $comments[59]; |
|
||||
$comments[59] = $comments[58]; |
|
||||
$comments[58] = $comments[57]; |
|
||||
$comments[57] = -1; |
|
||||
$responses[60] = $responses[59]; |
|
||||
$responses[59] = $responses[58]; |
|
||||
$responses[58] = $responses[57]; |
|
||||
$answers[57] = -1; |
|
||||
} |
|
||||
my ($slug,$steady,$energetic) = (5,5,5); |
|
||||
my @tmp = split(/\?/,$responses[58]); |
|
||||
for ($i = 1; $i<= 60; $i+=3) { |
|
||||
#print STDERR "$i - $tmp[$i] - $slug,\n"; |
|
||||
if ($tmp[$i] =~ /\d+/) { |
|
||||
last; |
|
||||
} else { |
|
||||
$slug += 5; |
|
||||
} |
|
||||
} |
|
||||
if ($slug == 105) {$slug = 0;} |
|
||||
foreach ($i = 2; $i<= 60; $i+=3) { |
|
||||
#print STDERR "$i - $tmp[$i] - $steady\n"; |
|
||||
if ($tmp[$i] =~ /\d+/) { |
|
||||
last; |
|
||||
} else { |
|
||||
$steady += 5; |
|
||||
} |
|
||||
} |
|
||||
if ($steady == 105) {$steady = 0;} |
|
||||
foreach ($i = 3; $i<= 60; $i+=3) { |
|
||||
#print STDERR "$i - $tmp[$i] - $energetic\n"; |
|
||||
if ($tmp[$i] =~ /\d+/) { |
|
||||
last; |
|
||||
} else { |
|
||||
$energetic += 5; |
|
||||
} |
|
||||
} |
|
||||
if ($energetic ==105) {$energetic = 0;} |
|
||||
if (($slug + $steady + $energetic) == 100) { |
|
||||
$answers[58] = [$slug,$steady,$energetic]; |
|
||||
} else { |
|
||||
#print STDERR "$slug, $steady, $energetic\n"; |
|
||||
$answers[58] = undef; |
|
||||
} |
|
||||
$answers[59] = $responses[59]; |
|
||||
#print STDERR Dumper(\@answers); |
|
||||
if (wantarray) { |
|
||||
return (\@answers,\@comments); |
|
||||
} else { |
|
||||
return \@answers; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub CommEffectData { |
|
||||
my ($client,$testid,$idlist,$groups) = @_; |
|
||||
my $grpMembership = &main::getGroupMemberships($client); |
|
||||
my $config = {'Purpose' => {'Clarity' => [17,25], |
|
||||
'Approval' => [21,29]}, |
|
||||
'Values' => {'Clarity' => [19,27], |
|
||||
'Approval' => [23,31]}, |
|
||||
'Vision' => {'Clarity' => [18,33], |
|
||||
'Approval' => [22,37]}, |
|
||||
'Goals' => {'Clarity' => [26,34], |
|
||||
'Approval' => [30,38]}, |
|
||||
'Procedures' => {'Clarity' => [20,35], |
|
||||
'Approval' => [24,39]}, |
|
||||
'Roles' => {'Clarity' => [28,36], |
|
||||
'Approval' => [32,40]} |
|
||||
}; |
|
||||
#my (%histograms,$claritysum,$approvalsum); |
|
||||
my $res; |
|
||||
foreach (keys %$config) { |
|
||||
@{$res->{'organization'}->{'histogram'}->{$_}->{'Clarity'}} = (0,0,0,0,0,0,0); |
|
||||
foreach my $i (0..6) { |
|
||||
@{$res->{'organization'}->{'histogram'}->{$_}->{'Approval'}->[$i]} = (0,0,0); |
|
||||
} |
|
||||
} |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; |
|
||||
$user =~ s/^$client.//; |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
next; |
|
||||
} |
|
||||
my $answers = &get_survey_results( $client, $user, $testid); |
|
||||
foreach (keys %$config) { |
|
||||
my ($clarity, $approval); |
|
||||
if (defined $answers->[$config->{$_}->{'Clarity'}->[0]] and |
|
||||
defined $answers->[$config->{$_}->{'Clarity'}->[1]] and |
|
||||
defined $answers->[$config->{$_}->{'Approval'}->[0]] and |
|
||||
defined $answers->[$config->{$_}->{'Approval'}->[1]]) { |
|
||||
$clarity = $answers->[$config->{$_}->{'Clarity'}->[0]] + |
|
||||
$answers->[$config->{$_}->{'Clarity'}->[1]]; |
|
||||
$res->{'organization'}->{'histogram'}->{$_}->{'Clarity'}->[$clarity]++; |
|
||||
$res->{'organization'}->{'claritysum'}->{$_}->{'number'}++; |
|
||||
$res->{'organization'}->{'claritysum'}->{$_}->{'value'} += $clarity; |
|
||||
$approval = $answers->[$config->{$_}->{'Approval'}->[0]] + |
|
||||
$answers->[$config->{$_}->{'Approval'}->[1]]; |
|
||||
$res->{'organization'}->{'approvalsum'}->{$_}->{'number'}++; |
|
||||
$res->{'organization'}->{'approvalsum'}->{$_}->{'value'} += $approval; |
|
||||
my $approvalhist; |
|
||||
if ($approval < 3) {$approvalhist = 0;} |
|
||||
elsif ($approval < 5) {$approvalhist = 1;} |
|
||||
else {$approvalhist = 2;} |
|
||||
$res->{'organization'}->{'histogram'}->{$_}->{'Approval'}->[$clarity]->[$approvalhist]++; |
|
||||
#if () { |
|
||||
if ($grpMembership and exists $grpMembership->{$user}) { |
|
||||
foreach my $group (@{$grpMembership->{$user}}) { |
|
||||
if (defined $idlist and not exists $groups->{$group}) { |
|
||||
# a subset of groups was chosen, and this group is not in that list |
|
||||
next; |
|
||||
} |
|
||||
if (not exists $res->{'groups'}->{$group}) { |
|
||||
foreach my $conf (keys %$config) { |
|
||||
@{$res->{'groups'}->{$group}->{'histogram'}->{$conf}->{'Clarity'}} = (0,0,0,0,0,0,0); |
|
||||
foreach my $i (0..6) { |
|
||||
@{$res->{'groups'}->{$group}->{'histogram'}->{$conf}->{'Approval'}->[$i]} = (0,0,0); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
$res->{'groups'}->{$group}->{'histogram'}->{$_}->{'Clarity'}->[$clarity]++; |
|
||||
$res->{'groups'}->{$group}->{'histogram'}->{$_}->{'Approval'}->[$clarity]->[$approvalhist]++; |
|
||||
$res->{'groups'}->{$group}->{'claritysum'}->{$_}->{'number'}++; |
|
||||
$res->{'groups'}->{$group}->{'claritysum'}->{$_}->{'value'} += $clarity; |
|
||||
$res->{'groups'}->{$group}->{'approvalsum'}->{$_}->{'number'}++; |
|
||||
$res->{'groups'}->{$group}->{'approvalsum'}->{$_}->{'value'} += $approval; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
my @groups = ($res->{'organization'}); |
|
||||
if (exists $res->{'groups'}) {push @groups, values(%{$res->{'groups'}});} |
|
||||
foreach my $group (@groups) { |
|
||||
my ($count,$claritytot,$approvaltot) = (scalar(keys(%{$group->{'claritysum'}})),0,0); |
|
||||
foreach (values %{$group->{'claritysum'}}) { |
|
||||
$_->{'value'} = 100*$_->{'value'}/(6*$_->{'number'}); |
|
||||
$claritytot += $_->{'value'}; |
|
||||
} |
|
||||
foreach (values %{$group->{'approvalsum'}}) { |
|
||||
$_->{'value'} = 100*$_->{'value'}/(6*$_->{'number'}); |
|
||||
$approvaltot += $_->{'value'}; |
|
||||
} |
|
||||
$group->{'overallclarity'} = ($count ? $claritytot/$count : undef); |
|
||||
$group->{'overallapproval'} = ($count ? $approvaltot/$count : undef); |
|
||||
} |
|
||||
#print STDERR Dumper($res); |
|
||||
return $res; |
|
||||
} |
|
||||
|
|
||||
sub TrustLevelData { |
|
||||
my ($client,$testid,$idlist,$groups) = @_; |
|
||||
my $grpMembership = &main::getGroupMemberships($client); |
|
||||
my %reversed = (2 => 1, 13 => 1, 15 => 1); |
|
||||
my %config = ('Openness' => [1,5,9,13], |
|
||||
'Congruence' => [2,6,10,14], |
|
||||
'Acceptance' => [3,7,11,15], |
|
||||
'Reliability' => [4,8,12,16] |
|
||||
); |
|
||||
my ($res,%defhistograms); |
|
||||
@defhistograms{keys(%config)} = ([0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0]); |
|
||||
@{$res->{'organization'}->{'histogram'}}{keys(%config)} = ([0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0]); |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; |
|
||||
$user =~ s/^$client.//; |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
next; |
|
||||
} |
|
||||
my $answers = &get_survey_results( $client, $user, $testid); |
|
||||
CONFIG: foreach (keys %config) { |
|
||||
my $value; |
|
||||
foreach my $i (@{$config{$_}}) { |
|
||||
if (not defined $answers->[$i]) { |
|
||||
# We are missing a response in one of the data points for this category, |
|
||||
# skip the category for this canidate. |
|
||||
$value = 0; |
|
||||
next CONFIG; |
|
||||
} |
|
||||
if (exists $reversed{$i}) { |
|
||||
$value += (4 - $answers->[$i]); |
|
||||
} else { |
|
||||
$value += $answers->[$i]; |
|
||||
} |
|
||||
} |
|
||||
$res->{'organization'}->{'trust'}->{$_}->{'number'}++; |
|
||||
#print STDERR "$_: ($res->{'organization'}->{'trust'}->{$_}->{'number'}, $value => "; |
|
||||
my $hvalue = $value - 4; |
|
||||
$res->{'organization'}->{'trust'}->{$_}->{'value'}+=$value; |
|
||||
if ($hvalue < 0) {$hvalue = 0;} |
|
||||
if ($hvalue > 8) {$hvalue = 8}; |
|
||||
$res->{'organization'}->{'histogram'}->{$_}->[$hvalue]++; |
|
||||
if ($grpMembership and exists $grpMembership->{$user}) { |
|
||||
# it isn't clear what by group breakout should be |
|
||||
# when the reports are limited by groups, so skip it. |
|
||||
foreach my $group (@{$grpMembership->{$user}}) { |
|
||||
if (defined $idlist and not exists $groups->{$group}) { |
|
||||
# a subset of groups was chosen, and this group is not in that list |
|
||||
next; |
|
||||
} |
|
||||
if (not exists $res->{'groups'}->{$group}) { |
|
||||
@{$res->{'groups'}->{$group}->{'histogram'}}{keys(%config)} = ([0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0], |
|
||||
[0,0,0,0,0,0,0,0,0]); |
|
||||
} |
|
||||
$res->{'groups'}->{$group}->{'trust'}->{$_}->{'number'}++; |
|
||||
$res->{'groups'}->{$group}->{'trust'}->{$_}->{'value'}+=$value; |
|
||||
$res->{'groups'}->{$group}->{'histogram'}->{$_}->[$hvalue]++; |
|
||||
} |
|
||||
} |
|
||||
$value = 0; |
|
||||
$hvalue = 0; |
|
||||
} |
|
||||
} |
|
||||
#print STDERR Dumper($res->{'organization'}); |
|
||||
my @groups = ($res->{'organization'}); |
|
||||
if (exists $res->{'groups'}) {push @groups, values(%{$res->{'groups'}});} |
|
||||
foreach my $group (@groups) { |
|
||||
my ($count,$overall) = (scalar(keys(%{$group->{'trust'}})),0); |
|
||||
foreach (values %{$group->{'trust'}}) { |
|
||||
#print STDERR "($_->{'value'}, $_->{'number'})\n"; |
|
||||
$_->{'value'} = 100*$_->{'value'}/(16*$_->{'number'}); |
|
||||
$overall += $_->{'value'}; |
|
||||
} |
|
||||
$group->{'overalltrust'} = ($count ? $overall/$count : undef); |
|
||||
} |
|
||||
#print STDERR Dumper($res->{'organization'}); |
|
||||
return $res; |
|
||||
} |
|
||||
|
|
||||
sub ValuesData { |
|
||||
my ($client,$testid,$idlist,$groups) = @_; |
|
||||
my $grpMembership = &main::getGroupMemberships($client); |
|
||||
#print STDERR Dumper( $grpMembership ); |
|
||||
#my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
my %config ; |
|
||||
if ($testid eq "passion") { |
|
||||
%config = ('Straightforwardness' => 21, |
|
||||
'Honesty' => 23, |
|
||||
'Receptivity' => 25, |
|
||||
'Disclosure' => 27, |
|
||||
'Respect' => 29, |
|
||||
'Recognition' => 31, |
|
||||
'Seeks Excellence' => 33, |
|
||||
'Keeps Commitments' => 35, |
|
||||
); |
|
||||
} else { |
|
||||
%config = ('Straightforwardness' => 41, |
|
||||
'Honesty' => 43, |
|
||||
'Receptivity' => 45, |
|
||||
'Disclosure' => 47, |
|
||||
'Respect' => 49, |
|
||||
'Recognition' => 51, |
|
||||
'Seeks Excellence' => 53, |
|
||||
'Keeps Commitments' => 55, |
|
||||
); |
|
||||
} |
|
||||
# data is stored [Personal Importance, Work Performance] |
|
||||
my %levels = map(($_ => [0,0]), keys(%config)); |
|
||||
my %count = map(($_ => 0), keys(%config)); # number of responses |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
my $res = {}; |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; |
|
||||
$user =~ s/^$client.//; |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
next; |
|
||||
} |
|
||||
my $answers = &get_survey_results( $client, $user, $testid); |
|
||||
foreach (keys %config) { |
|
||||
if (not defined $answers->[$config{$_}] or not defined $answers->[$config{$_}+1]) { |
|
||||
next; |
|
||||
} |
|
||||
$res->{'organization'}->{$_}->{'count'}++; |
|
||||
$res->{'organization'}->{$_}->{'Personal Importance'} += $answers->[$config{$_}]+1; |
|
||||
$res->{'organization'}->{$_}->{'Work Performance'} += $answers->[$config{$_}+1]+1; |
|
||||
if ($grpMembership and exists $grpMembership->{$user}) { |
|
||||
# it isn't clear what by group breakout should be |
|
||||
# when the reports are limited by groups, so skip it. |
|
||||
foreach my $group (@{$grpMembership->{$user}}) { |
|
||||
if (defined $idlist and not exists $groups->{$group}) { |
|
||||
# a subset of groups was chosen, and this group is not in that list |
|
||||
next; |
|
||||
} |
|
||||
$res->{'groups'}->{$group}->{$_}->{'count'}++; |
|
||||
#my $bob = $answers->[$config{$_}]+1; |
|
||||
#print STDERR "User: $user Group: $group Value: $_ Answer: $bob\n"; |
|
||||
$res->{'groups'}->{$group}->{$_}->{'Personal Importance'} += $answers->[$config{$_}]+1; |
|
||||
$res->{'groups'}->{$group}->{$_}->{'Work Performance'} += $answers->[$config{$_}+1]+1; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
my @tmp = ($res->{'organization'}); |
|
||||
if (exists $res->{'groups'}) {push @tmp, values(%{$res->{'groups'}});} |
|
||||
foreach my $grp (@tmp) { |
|
||||
foreach (keys %config) { |
|
||||
if (not $grp->{$_}->{'count'}) {next;} |
|
||||
$grp->{$_}->{'Personal Importance'} /= $grp->{$_}->{'count'}; |
|
||||
$grp->{$_}->{'Work Performance'} /= $grp->{$_}->{'count'}; |
|
||||
$grp->{'Personal Importance'} += $grp->{$_}->{'Personal Importance'}; |
|
||||
$grp->{'Work Performance'} += $grp->{$_}->{'Work Performance'}; |
|
||||
$grp->{'gap'} += $grp->{$_}->{'Personal Importance'} - $grp->{$_}->{'Work Performance'}; |
|
||||
} |
|
||||
} |
|
||||
return $res; |
|
||||
} |
|
||||
|
|
||||
sub diversityData { |
|
||||
my ($client,$testid,$idlist,$groups) = @_; |
|
||||
# warn "diversityData called" ; # HBI Debug |
|
||||
my $grpMembership = &main::getGroupMemberships($client); |
|
||||
#print STDERR Dumper( $grpMembership ); |
|
||||
#my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
my %config = ('Respectfulness' => 60, |
|
||||
'Speaking Up' => 62, |
|
||||
'Divergent Thinking' => 64, |
|
||||
'Freedom from Harassment' => 66, |
|
||||
'Fairness of Decisions' => 68 |
|
||||
); |
|
||||
# data is stored [Personal Importance, Work Performance] |
|
||||
my %levels = map(($_ => [0,0]), keys(%config)); |
|
||||
my %count = map(($_ => 0), keys(%config)); # number of responses |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
my $res = {}; |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; |
|
||||
$user =~ s/^$client.//; |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
next; |
|
||||
} |
|
||||
my $answers = &get_survey_results( $client, $user, $testid); |
|
||||
foreach (keys %config) { |
|
||||
if (not defined $answers->[$config{$_}] or not defined $answers->[$config{$_}+1]) { |
|
||||
next; |
|
||||
} |
|
||||
$res->{'organization'}->{$_}->{'count'}++; |
|
||||
$res->{'organization'}->{$_}->{'Personal Importance'} += $answers->[$config{$_}]+1; |
|
||||
$res->{'organization'}->{$_}->{'Work Performance'} += $answers->[$config{$_}+1]+1; |
|
||||
if ($grpMembership and exists $grpMembership->{$user}) { |
|
||||
# it isn't clear what by group breakout should be |
|
||||
# when the reports are limited by groups, so skip it. |
|
||||
foreach my $group (@{$grpMembership->{$user}}) { |
|
||||
if (defined $idlist and not exists $groups->{$group}) { |
|
||||
# a subset of groups was chosen, and this group is not in that list |
|
||||
next; |
|
||||
} |
|
||||
$res->{'groups'}->{$group}->{$_}->{'count'}++; |
|
||||
#my $bob = $answers->[$config{$_}]+1; |
|
||||
#print STDERR "User: $user Group: $group Value: $_ Answer: $bob\n"; |
|
||||
$res->{'groups'}->{$group}->{$_}->{'Personal Importance'} += $answers->[$config{$_}]+1; |
|
||||
$res->{'groups'}->{$group}->{$_}->{'Work Performance'} += $answers->[$config{$_}+1]+1; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
my @tmp = ($res->{'organization'}); |
|
||||
if (exists $res->{'groups'}) {push @tmp, values(%{$res->{'groups'}});} |
|
||||
foreach my $grp (@tmp) { |
|
||||
foreach (keys %config) { |
|
||||
if (not $grp->{$_}->{'count'}) {next;} |
|
||||
$grp->{$_}->{'Personal Importance'} /= $grp->{$_}->{'count'}; |
|
||||
$grp->{$_}->{'Work Performance'} /= $grp->{$_}->{'count'}; |
|
||||
$grp->{'Personal Importance'} += $grp->{$_}->{'Personal Importance'}; |
|
||||
$grp->{'Work Performance'} += $grp->{$_}->{'Work Performance'}; |
|
||||
$grp->{'gap'} += $grp->{$_}->{'Personal Importance'} - $grp->{$_}->{'Work Performance'}; |
|
||||
} |
|
||||
} |
|
||||
return $res; |
|
||||
} |
|
||||
|
|
||||
sub KindsOfPeopleData { |
|
||||
my ($client,$testid,$idlist,$groups) = @_; |
|
||||
my $grpMembership = &main::getGroupMemberships($client); |
|
||||
#print STDERR Dumper( $grpMembership ); |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete,$client,$testid); |
|
||||
my $res = {'self' =>{}}; |
|
||||
$res->{'self'}->{'count'} = 0; |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/\.$testid$//; |
|
||||
$user =~ s/^$client\.//; |
|
||||
#print STDERR " $user\n"; |
|
||||
my $answers = &get_survey_results( $client, $user, $testid); |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
#print STDERR "Skipping $user\n"; |
|
||||
next; |
|
||||
} |
|
||||
$res->{'Number of Surveys'}++; |
|
||||
#print STDERR Dumper($answers); |
|
||||
if (exists $res->{'self'} and defined $answers->[57] ) { |
|
||||
#print STDERR "BOOOO:$user:$answers->[57]:$answers->[57]->[0] $answers->[57]->[1] $answers->[57]->[2]\n"; |
|
||||
if ($answers->[57] >= 0) { |
|
||||
my @types = ('Rebellious', 'Compliant', 'Self-Directed'); |
|
||||
$res->{'self'}->{'count'}++; |
|
||||
$res->{'self'}->{$types[$answers->[57]]} += 100; |
|
||||
} |
|
||||
} |
|
||||
if (defined $answers->[58] ) { |
|
||||
#print STDERR "BOOOO::$user $answers->[58]->[0] $answers->[58]->[1] $answers->[58]->[2]\n"; |
|
||||
$res->{'organization'}->{'count'}++; |
|
||||
$res->{'organization'}->{'Rebellious'} += $answers->[58]->[0]; |
|
||||
$res->{'organization'}->{'Compliant'} += $answers->[58]->[1]; |
|
||||
$res->{'organization'}->{'Self-Directed'} += $answers->[58]->[2]; |
|
||||
if ($grpMembership and exists $grpMembership->{$user}) { |
|
||||
foreach my $group (@{$grpMembership->{$user}}) { |
|
||||
if (defined $idlist and not exists $groups->{$group}) { |
|
||||
# a subset of groups was chosen, and this group is not in that list |
|
||||
next; |
|
||||
} |
|
||||
$res->{'groups'}->{$group}->{'count'}++; |
|
||||
$res->{'groups'}->{$group}->{'Rebellious'} += $answers->[58]->[0]; |
|
||||
$res->{'groups'}->{$group}->{'Compliant'} += $answers->[58]->[1]; |
|
||||
$res->{'groups'}->{$group}->{'Self-Directed'} += $answers->[58]->[2]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($res->{'self'}->{'count'} < 1) { |
|
||||
delete $res->{'self'}; |
|
||||
} |
|
||||
if (not defined $res) { |
|
||||
return undef; |
|
||||
} |
|
||||
my @tmp = ($res->{'organization'}); |
|
||||
if (exists $res->{'groups'}) {push @tmp, values(%{$res->{'groups'}});} |
|
||||
if (exists $res->{'self'}) {push @tmp, $res->{'self'};} |
|
||||
foreach (@tmp) { |
|
||||
if (not $_->{'count'}) { |
|
||||
$_ = undef; |
|
||||
next; |
|
||||
} |
|
||||
$_->{'Rebellious'} /= $_->{'count'}; |
|
||||
$_->{'Compliant'} /= $_->{'count'}; |
|
||||
$_->{'Self-Directed'} /= $_->{'count'}; |
|
||||
} |
|
||||
#print STDERR Dumper($res,$idlist); |
|
||||
return $res; |
|
||||
} |
|
||||
|
|
||||
1; |
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,623 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: IntegroTeam.pl,v 1.13 2006/04/12 19:18:47 ddoughty Exp $ |
|
||||
# |
|
||||
# Source File: Integro.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES); |
|
||||
use vars qw($testcomplete $testinprog $testcomplete $testpending $cgiroot $pathsep $dataroot @rptparams); |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
|
|
||||
if ($FORM{'tstid'}) { |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
} elsif (!$rptparams[0]) { |
|
||||
# Check for multiple tests |
|
||||
my @trecs = &get_test_list($CLIENT{'clid'}); #tests in an array |
|
||||
my @tmptrecs = (); |
|
||||
for (1 .. $#trecs) { |
|
||||
my ($id, $desc) = split(/&/, $trecs[$_]); #id=testid, descr=test description |
|
||||
if ($id =~ "^TAQ") {push @tmptrecs, join('&', "$desc", "$id");} |
|
||||
} |
|
||||
@trecs = sort @tmptrecs; |
|
||||
if ($#trecs > 0) { |
|
||||
# show test chooser |
|
||||
&print_test_chooser(@trecs); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
#print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Is this report for a specific canidate? |
|
||||
my $cndid; |
|
||||
#print STDERR "$FORM{'specificuser'} $FORM{'cndid'}\n"; |
|
||||
if ($FORM{'specificuser'} and (not $idlist or $idlist->{$FORM{'cndid'}})) { |
|
||||
$cndid = $FORM{'cndid'}; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'commeffect') { |
|
||||
&CommEffectReport($idlist, $groups, $timestamp, $cndid); |
|
||||
} elsif ($FORM{'reportname'} eq 'commeffectsummary') { |
|
||||
&CommEffectSummary($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'trustlevel') { |
|
||||
&TrustLevelReport($idlist, $groups, $timestamp, $cndid); |
|
||||
} elsif ($FORM{'reportname'} eq 'trustlevelsummary') { |
|
||||
&TrustLevelSummary($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'comments') { |
|
||||
&CommentsReport($idlist, $timestamp, 0); |
|
||||
} elsif ($FORM{'reportname'} eq 'comments2') { |
|
||||
&CommentsReport($idlist, $timestamp, 1); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n". |
|
||||
"</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) 2004-$year, Integro Leadership Institute<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
|
|
||||
my $orgname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $test; |
|
||||
if ($FORM{'tstid'}) { |
|
||||
$test = $FORM{'tstid'}; |
|
||||
} elsif ($rptparams[0]) { |
|
||||
$test = $rptparams[0]; |
|
||||
} else { |
|
||||
$test = "TAQ01"; |
|
||||
} |
|
||||
my ($tstid) = grep((/($test\s*)&/ && ($_=$1)),get_data("tests.$CLIENT{'clid'}")); |
|
||||
if (not $tstid) { |
|
||||
print HTMLHeader("Error! No Team Alignment Questionnaire Found."); |
|
||||
print "<h1>Error! No Team Alignment Questionnaire Found.</h1>\n"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
my $grplist = getGroups($CLIENT{'clid'}); |
|
||||
my @grplist = keys(%$grplist); |
|
||||
my $grplistlen = $#grplist + 2; |
|
||||
$js .= "var groups = new Array($grplistlen)\;\n"; |
|
||||
foreach my $grp (@grplist) { |
|
||||
my $gidlist = getIdlist($CLIENT{'clid'}, $grp); |
|
||||
my @gidklist = keys(%$gidlist); |
|
||||
$js .= "groups[\"$grp\"] = ["; |
|
||||
foreach my $cnd (@gidklist) { |
|
||||
$js .= "\"$cnd\", "; |
|
||||
} |
|
||||
if ($#gidklist > -1) { $js = substr($js,0,-2); } |
|
||||
$js .= "]\;\n"; |
|
||||
$js .= "groups[\"$grp\"] = groups[\"$grp\"].sort()\;\n"; |
|
||||
} |
|
||||
$js .= "groups[\"all\"] = ["; |
|
||||
my $users = get_users($CLIENT{'clid'},"$tstid"); |
|
||||
my @users = keys(%$users); |
|
||||
foreach my $cnd (@users) { |
|
||||
$js .= "\"$cnd\", "; |
|
||||
} |
|
||||
if ($#users + 1) { $js = substr($js,0,-2); } |
|
||||
$js .= "]\;\n"; |
|
||||
$js .= "groups[\"all\"] = groups[\"all\"].sort()\;\n"; |
|
||||
$js .= "function removeOptions(optionMenu) { \ |
|
||||
var oml = optionMenu.options.length; \ |
|
||||
for (var i=0; i < oml; i++) { \ |
|
||||
optionMenu.remove(0); \ |
|
||||
} \ |
|
||||
} \ |
|
||||
\ |
|
||||
function addOptions(optionList, optionMenu) { \ |
|
||||
var oml = optionMenu.options.length; \ |
|
||||
for (var i=0; i < optionList.length; i++) { \ |
|
||||
optionMenu[oml+i] = new Option(optionList[i], optionList[i]); \ |
|
||||
} \ |
|
||||
} "; |
|
||||
$js .= "function buildGroupList(optionListArray, optionListMenu, optionMenu) {\n\t". |
|
||||
" removeOptions(optionMenu);". |
|
||||
" for (var i=0; i<optionListMenu.options.length; i++) {". |
|
||||
" if (optionListMenu.options[i].selected) {". |
|
||||
" addOptions(optionListArray[optionListMenu.options[i].value], optionMenu);". |
|
||||
" }". |
|
||||
" }". |
|
||||
"};\n"; |
|
||||
|
|
||||
print HTMLHeader("Team Alignment Reports",$js); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
print "<input type=hidden name=\"tstid\" value=\"$tstid\">\n"; |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border=\"1\">\n<caption>Team Alignment Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked onClick=\"removeOptions(document.integrorpt.cndid); addOptions(groups['all'], this.form.cndid);\">All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\" onClick=\"buildGroupList(groups, this.form.idlist, this.form.cndid)\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</td><td valign=\"top\"><input type=\"checkbox\" name=\"specificuser\">Specific User<br>"; |
|
||||
print "<select name=\"cndid\" onchange='this.form.specificuser.checked=true;'>\n"; |
|
||||
#my $users = get_users($CLIENT{'clid'},"$tstid"); |
|
||||
#print map("<option value=\"$_\">$_</option>\n",sort(keys(%$users))); |
|
||||
print "</select></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$orgname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"3\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print "<hr>\n"; |
|
||||
print "<input type=\"checkbox\" name=\"pdf\">Display reports as PDF\n"; |
|
||||
print "<p> <ul style=\"list-style: none\"><li><a href=\"javascript:parmsIntegro(document.integrorpt,'trustlevel');\">Team Trust Level Report</a></li>". |
|
||||
"<!--<li><a href=\"javascript:parmsIntegro(document.integrorpt,'trustlevelsummary');\">Team Trust Level Summary</a></li>--></ul></p>\n"; |
|
||||
print "<p><ul style=\"list-style: none\"><li><a href=\"javascript:parmsIntegro(document.integrorpt,'commeffect');\">Team Alignment Report</a></li>". |
|
||||
"<!--<li><a href=\"javascript:parmsIntegro(document.integrorpt,'commeffectsummary');\">Team Alignment Summary</a></li>--></ul></p>\n"; |
|
||||
print "<p>General Reports<ul style=\"list-style: none\"><li><a href=\"javascript:parmsIntegro(document.integrorpt,'comments');\">Comments</a></li>"; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'comments2');\">Comments by Category</a></li>"; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
#my $commurl = "/cgi-bin/teststats.pl?tstid=SAS01". |
|
||||
# "&tid=$FORM{'tid'}&rptid=ACT-C-004&rptdesc=Test%20Statistics%20by%20Test". |
|
||||
# "&testsummary=composite&showcmts=donot"; |
|
||||
print "<li><a href=\"javascript:commIntegro(document.integrorpt);\">Question Statistics</a></li></p>\n"; |
|
||||
print "</form>"; |
|
||||
print "<script language=\"JavaScript\">\n<!-- \n"; |
|
||||
print "if (document.integrorpt.grouping[0].checked) { addOptions(groups['all'], document.integrorpt.cndid);} else { buildGroupList(groups, document.integrorpt.idlist, document.integrorpt.cndid)}"; |
|
||||
print "\n -->\n</script>\n"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
# Also known as the Group Alignment report |
|
||||
sub CommEffectReport { |
|
||||
my ($idlist,$groups,$timestamp,$cndid) = @_; |
|
||||
my $data = &CommEffectData($CLIENT{'clid'},$TEST{'id'},$idlist,$groups); |
|
||||
my $user; |
|
||||
if ($cndid) {$user = &CommEffectData($CLIENT{'clid'},$TEST{'id'},{$cndid => 1},$groups);&get_candidate_profile($CLIENT{'clid'},$cndid);} |
|
||||
my $claritysum = $data->{'organization'}->{'claritysum'}; |
|
||||
my $approvalsum = $data->{'organization'}->{'approvalsum'}; |
|
||||
my $histograms = $data->{'organization'}->{'histogram'}; |
|
||||
print HTMLHeaderPlain("Team Alignment Report"); |
|
||||
print "<Center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\"><b>Team Alignment Questionnaire<br>Team Alignment Report </b><br>$CANDIDATE{'sal'} $CANDIDATE{'nmf'} $CANDIDATE{'nmm'} $CANDIDATE{'nml'}</font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>The Degree to which Team Members are in Alignment</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
my $groups = getGroups($CLIENT{'clid'}); |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Groups: " |
|
||||
.join(", ",map($groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n"; |
|
||||
} else { |
|
||||
#print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Organization-wide Report</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b></b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b><table border><tr><th> </th><th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Very Unclear</b></font></th><th> </th>". |
|
||||
"<th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Moderately Unclear</b></font></th><th> </th><th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Moderately Clear</b></font></th>". |
|
||||
"<th> </th><th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Very Clear</b></font></th><th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Team Clarity</b></font></th>". |
|
||||
"<th><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b>Team Approval</b></font></th></tr>\n"; |
|
||||
# fill in the rows |
|
||||
my $overall = {'clarity' => 0, 'approval' => 0}; |
|
||||
foreach my $row (qw(Purpose Values Vision Goals Procedures Roles)) { |
|
||||
print "<tr><th>$row</th>"; |
|
||||
for my $i (0..6) { |
|
||||
print "<td align=\"center\">"; |
|
||||
if ($histograms->{$row}->{'Clarity'}->[$i]) { |
|
||||
if ($histograms->{$row}->{'Approval'}->[$i]->[2]) { |
|
||||
my $img = "/graphic/face-smile.gif"; |
|
||||
if ($user and $user->{'organization'}->{'histogram'}->{$row}->{'Approval'}->[$i]->[2]) { |
|
||||
$img = "/graphic/face-smile-green.gif"; |
|
||||
} |
|
||||
print "<img src=\"$img\"><sub>$histograms->{$row}->{'Approval'}->[$i]->[2]</sub><br>"; |
|
||||
} |
|
||||
if ($histograms->{$row}->{'Approval'}->[$i]->[1]) { |
|
||||
my $img = "/graphic/face-red.gif"; |
|
||||
if ($user and $user->{'organization'}->{'histogram'}->{$row}->{'Approval'}->[$i]->[1]) { |
|
||||
$img = "/graphic/face-red-green.gif"; |
|
||||
} |
|
||||
print "<img src=\"$img\"><sub>$histograms->{$row}->{'Approval'}->[$i]->[1]</sub><br>"; |
|
||||
} |
|
||||
if ($histograms->{$row}->{'Approval'}->[$i]->[0]) { |
|
||||
my $img = "/graphic/face-blue.gif"; |
|
||||
if ($user and $user->{'organization'}->{'histogram'}->{$row}->{'Approval'}->[$i]->[0]) { |
|
||||
$img = "/graphic/face-blue-green.gif"; |
|
||||
} |
|
||||
print "<img src=\"$img\"><sub>$histograms->{$row}->{'Approval'}->[$i]->[0]</sub>"; |
|
||||
} |
|
||||
} else { |
|
||||
print " "; |
|
||||
} |
|
||||
print "</td>"; |
|
||||
} |
|
||||
printf "<td align=\"center\">%.1f %%</td>\n", $claritysum->{$row}->{'value'}; |
|
||||
printf "<td align=\"center\">%.1f %%</td>\n", $approvalsum->{$row}->{'value'}; |
|
||||
print "</tr>\n"; |
|
||||
} |
|
||||
print "</table>\n<p>Position = Team Clarity</p>\n<p>Countenance = Personal Approval</p>\n"; |
|
||||
#print "<table border><caption><b>Overall Team Alignment</b></caption>\n"; |
|
||||
#printf "<tr><th>Clarity</th><td>%.1f %%</td></tr>\n", $data->{'organization'}->{'overallclarity'}; |
|
||||
#printf "<tr><th>Approval</th><td>%.1f %%</td></tr>\n", $data->{'organization'}->{'overallapproval'}; |
|
||||
#print "</table></b></font>\n"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub CommEffectSummary { |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $data = &CommEffectData($CLIENT{'clid'},$TEST{'id'},$idlist,$groups); |
|
||||
$groups = getGroups($CLIENT{'clid'}); |
|
||||
print HTMLHeaderPlain("Team Alignment Summary"); |
|
||||
print "<Center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\"><b>Team Alignment Questionnaire<br>Team Alignment Summary</i></b></font><br><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>The degree to which Employees are Aligned with the Organization</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if (defined $idlist) { |
|
||||
my $groups = getGroups($CLIENT{'clid'}); |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n"; |
|
||||
} else { |
|
||||
#print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Organization-wide Report</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b></b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b><table border>\n"; |
|
||||
print "<tr><td> </th><th>Clarity</th><th>Approval</th></tr>\n"; |
|
||||
print "<tr><td>Overall</td>"; |
|
||||
printf "<td>%.1f %%</td>",$data->{'organization'}->{'overallclarity'}; |
|
||||
printf "<td>%.1f %%</td></tr>\n", $data->{'organization'}->{'overallapproval'}; |
|
||||
if (exists $data->{'groups'}) { |
|
||||
print "<tr><th colspan=3 align=\"left\">Group Breakdown</th></tr>\n"; |
|
||||
print "<tr><th>Group</th><th>Clarity</th><th>Approval</th></tr>\n"; |
|
||||
foreach my $grp (sort keys %{$data->{'groups'}}) { |
|
||||
print "<tr><td>$groups->{$grp}->{'grpnme'}</td>"; |
|
||||
printf "<td>%.1f %%</td>", $data->{'groups'}->{$grp}->{'overallclarity'}; |
|
||||
printf "<td>%.1f %%</td></tr>\n", $data->{'groups'}->{$grp}->{'overallapproval'}; |
|
||||
} |
|
||||
} |
|
||||
print "</table></b></font>\n"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub TrustLevelReport { |
|
||||
my ($idlist,$groups,$timestamp,$cndid) = @_; |
|
||||
my $data = &TrustLevelData($CLIENT{'clid'},$TEST{'id'},$idlist,$groups); |
|
||||
my $user; |
|
||||
if ($cndid) {$user = &TrustLevelData($CLIENT{'clid'},$TEST{'id'},{$cndid => 1},$groups);&get_candidate_profile($CLIENT{'clid'},$cndid);} |
|
||||
my $histograms = $data->{'organization'}->{'histogram'}; |
|
||||
my $trust = $data->{'organization'}->{'trust'}; |
|
||||
print HTMLHeaderPlain("Team Trust Level Report"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\"><b>Team Alignment Questionnaire<br>Team Trust Level Report</b><br>$CANDIDATE{'sal'} $CANDIDATE{'nmf'} $CANDIDATE{'nmm'} $CANDIDATE{'nml'} </font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>The level of Trust Building behaviors</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
my $groups = getGroups($CLIENT{'clid'}); |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Groups: " |
|
||||
.join(", ",map($groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n"; |
|
||||
} else { |
|
||||
#print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Organization-wide Report</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b></b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b><table border=\"1\"><tr><th> </th><th> </th><th>Team Trust Level</th></tr>\n"; |
|
||||
my $baseurl; |
|
||||
if (defined($ENV{'SSL_PROTOCOL'})) { |
|
||||
$baseurl = "https://"; |
|
||||
} else { |
|
||||
$baseurl = "http://"; |
|
||||
} |
|
||||
$baseurl .= $ENV{'HTTP_HOST'}; |
|
||||
|
|
||||
$baseurl .= "/cgi-bin/bargraph.pl?labels=Low::::Medium::::High&title=Trust%20Level&ylabel=Respondents"; |
|
||||
$baseurl .= "&xdim=500&ydim=150"; |
|
||||
foreach my $row (qw(Congruence Openness Acceptance Reliability)) { |
|
||||
my $url; |
|
||||
if (not $user) { |
|
||||
$url = "$baseurl&values=".join(":",@{$histograms->{$row}}); |
|
||||
} else { |
|
||||
my (@values,@values2); |
|
||||
for (my $i=0; $i < @{$histograms->{$row}}; $i++) { |
|
||||
if ($user->{'organization'}->{'histogram'}->{$row}->[$i]) { |
|
||||
push @values ,''; |
|
||||
push @values2 , $histograms->{$row}->[$i]; |
|
||||
} else { |
|
||||
push @values2 ,''; |
|
||||
push @values , $histograms->{$row}->[$i]; |
|
||||
} |
|
||||
} |
|
||||
$url = "$baseurl&values=".join(":",@values)."&values2=".join(":",@values2); |
|
||||
} |
|
||||
print "<tr><th>$row</th>"; |
|
||||
print "<td><img src=\"$url\"></td>"; |
|
||||
printf "<td align=\"center\">%.1f%% </td></tr>\n", $trust->{$row}->{'value'}; |
|
||||
} |
|
||||
print "</table></b></font>\n"; |
|
||||
#printf "<P><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"2\"><b>Overall Team Level of Trust</b></font> = %.1f %%.</p>\n",$data->{'organization'}->{'overalltrust'}; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub TrustLevelSummary { |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $data = TrustLevelData($CLIENT{'clid'},$TEST{'id'},$idlist,$groups); |
|
||||
$groups = getGroups($CLIENT{'clid'}); |
|
||||
print HTMLHeaderPlain("Team Trust Level Summary"); |
|
||||
print "<Center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\"><b>Team Alignment Questionnaire<br>Team Trust Level Summary</b></font><br><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>The level of Trust Building behaviors</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
my $groups = getGroups($CLIENT{'clid'}); |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n"; |
|
||||
} else { |
|
||||
#print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Organization-wide Summary</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b></b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\"><b><table border>\n"; |
|
||||
print "<tr><td> </th><th>Team Trust Level</th></tr>\n"; |
|
||||
print "<tr><td>Overall</td>"; |
|
||||
printf "<td>%.1f %%</td></tr>\n", $data->{'organization'}->{'overalltrust'}; |
|
||||
if (exists $data->{'groups'}) { |
|
||||
print "<tr><th colspan=2 align=\"left\">Group Breakdown</th></tr>\n"; |
|
||||
print "<tr><th>Group</th><th>Team Trust Level</th></tr>\n"; |
|
||||
foreach my $grp (sort keys %{$data->{'groups'}}) { |
|
||||
print "<tr><td>$groups->{$grp}->{'grpnme'}</td>"; |
|
||||
printf "<td>%.1f %%</td></tr>\n", $data->{'groups'}->{$grp}->{'overalltrust'}; |
|
||||
} |
|
||||
} |
|
||||
print "</table></b></font>\n"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub CommentsReport { |
|
||||
my ($idlist, $timestamp, $bycat) = @_; |
|
||||
my @filelist = &get_test_result_files($testcomplete, $CLIENT{'clid'},$TEST{'id'}); |
|
||||
my @comments; |
|
||||
for (my $i=0; $i<=59; $i++) {$comments[$i] = [];} |
|
||||
my @questions = map([split(/&/,$_)],&get_question_list($TEST{'id'},$CLIENT{'clid'})); |
|
||||
foreach (@questions) {$_->[4] =~ s/:::.*$//;} |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$TEST{'id'}$//; |
|
||||
$user =~ s/^$CLIENT{'clid'}.//; |
|
||||
if (defined $idlist and not $idlist->{$user}) { |
|
||||
next; |
|
||||
} |
|
||||
my ($answers,$usercomm) = &get_survey_results( $CLIENT{'clid'}, $user, $TEST{'id'}); |
|
||||
for (my $i=1; $i<=58; $i++) { |
|
||||
if ($usercomm->[$i] == -1) { |
|
||||
$comments[$i] = -1; |
|
||||
} elsif ($usercomm->[$i]) { |
|
||||
push @{$comments[$i]},$usercomm->[$i]; |
|
||||
} |
|
||||
} |
|
||||
if ($answers->[59]) { |
|
||||
push @{$comments[59]},$answers->[59]; |
|
||||
} |
|
||||
} |
|
||||
print HTMLHeaderPlain("Comments Report"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\"><b>Team Alignment Questionnaire<br>Comments Report</b></font><br><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
my $groups = getGroups($CLIENT{'clid'}); |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Groups: " |
|
||||
.join(", ",map($groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n"; |
|
||||
} else { |
|
||||
#print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Organization-wide Report</b></font><br>\n"; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b></b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "</center>\n"; |
|
||||
print "<blockquote>\n"; |
|
||||
|
|
||||
my @outary = (); |
|
||||
for (my $i=1; $i <=40; $i++) { |
|
||||
if ($comments[$i] == -1) { |
|
||||
# inactive question |
|
||||
next; |
|
||||
} |
|
||||
$outary[$i] = "<hr width=\"100%\"><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"2\"><b>\n"; |
|
||||
$outary[$i] .= "$questions[$i]->[0] - $questions[$i]->[4]<p>\n"; |
|
||||
if (@{$comments[$i]}) { |
|
||||
$outary[$i] .= "<ul>\n"; |
|
||||
foreach (@{$comments[$i]}) { |
|
||||
$outary[$i] .= "<li>$_</li>\n"; |
|
||||
} |
|
||||
$outary[$i] .= "</ul>\n"; |
|
||||
} else { |
|
||||
$outary[$i] .= "<ul><li><small><i>No Comments</i></small></li></ul>\n"; |
|
||||
} |
|
||||
$outary[$i] .= "</b></font>\n"; |
|
||||
} |
|
||||
|
|
||||
# Read in .rgo file which defines question presentation order |
|
||||
my $out; |
|
||||
my $lookupfile = join($pathsep,$dataroot,"IntegroTAQ.rgo"); |
|
||||
if ($bycat && -e $lookupfile) { |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($lookupfile)) { |
|
||||
$out = ""; |
|
||||
my @lines = <$fh>; |
|
||||
$fh->close(); |
|
||||
shift @lines; |
|
||||
foreach (@lines) { |
|
||||
chomp; |
|
||||
my @line = split(/\&/,$_); |
|
||||
my $section = shift @line; |
|
||||
if ($section ne "") { |
|
||||
$out .= "<tr><td colspan=6><hr width=\"100\%\"></td></tr>\n"; |
|
||||
$out .= "<tr><td colspan=6><font size=+1><b>$section</b></font></td></tr>\n"; |
|
||||
} |
|
||||
foreach my $sub (@line) { |
|
||||
my ($subheader, $quess) = split(/:/,$sub); |
|
||||
if ($subheader ne "") { |
|
||||
$out .= "<hr width=100%><tr><td colspan=6><b>$subheader:</b></td></tr>\n"; |
|
||||
} |
|
||||
my @ques = split(/\,/,$quess); |
|
||||
foreach my $quesid (@ques) { |
|
||||
$out .= $outary[$quesid]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print $out; |
|
||||
} |
|
||||
} else { |
|
||||
for (1 .. $#outary) { |
|
||||
print $outary[$_]; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
print "<hr width=\"100%\">\n"; |
|
||||
print "</blockquote>\n"; |
|
||||
#print "<pre>".Dumper(\@questions,\@comments)."</pre>\n"; |
|
||||
print "<center>".HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub print_test_chooser { |
|
||||
my @trecs = @_; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) = split(/&/, $trecs[$_]); |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
$tstoption =" <TR> |
|
||||
<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD> |
|
||||
<TD valign=top><FONT SIZE=2>$desc</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> |
|
||||
</TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
print HTMLHeader("Integro Learning Custom Reports", $js); |
|
||||
print "<CENTER><B>Please choose the survey for which you would like reports:</B><br> |
|
||||
<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\"> |
|
||||
<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\"> |
|
||||
<input type=\"hidden\" name=\"tstid\" value=\"\"> |
|
||||
<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\"> |
|
||||
</form> |
|
||||
<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\"> |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
<TR> |
|
||||
<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD> |
|
||||
<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD> |
|
||||
</TR> |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
$tstoptions |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
print HTMLFooter(); |
|
||||
exit(); |
|
||||
} |
|
||||
@ -1,449 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
|
|
||||
# Source - LikertData.pl |
|
||||
|
|
||||
# Svn Keywords |
|
||||
# $Date$ |
|
||||
# $Revision$ |
|
||||
# $Author$ |
|
||||
# $HeadURL$ |
|
||||
# $Id$ |
|
||||
|
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
|
|
||||
require 'questionslib.pl'; |
|
||||
require Exporter; |
|
||||
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); |
|
||||
@ISA = qw(Exporter); |
|
||||
# Items to export into callers namespace by default. Note: do not export |
|
||||
# names by default without a very good reason. Use EXPORT_OK instead. |
|
||||
# Do not simply export all your public functions/methods/constants. |
|
||||
@EXPORT = qw(GetLikertData); |
|
||||
@EXPORT_OK = qw(); |
|
||||
$VERSION = '0.01'; |
|
||||
|
|
||||
sub GetLikertData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $idlist - optional Hash reference, keys are candidate ids, values are true for desired candidates. |
|
||||
# Returned value. |
|
||||
# $ret - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. |
|
||||
my ($client, $testid, $idlist) = @_ ; |
|
||||
my $ret = {} ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
unless (defined $idlist) { |
|
||||
# warn "In GetLikertData and idlist is undefined." ; |
|
||||
} |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
if (defined $idlist and %{$idlist} and not $idlist->{$user}) { |
|
||||
# warn "Skipped completed test for $user ." ; |
|
||||
# warn "Reference " . ref $idlist . " value." ; |
|
||||
next; |
|
||||
} |
|
||||
my $inact_ques = 0 ; # This is an offset for the inactive questions. |
|
||||
# The inactive questions are still listed, but without an answer. |
|
||||
# warn "Process completed test for $user ." ; |
|
||||
# Process this desired candidate's test answers. |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
# warn "user $user testid $testid resp $responses .\n" ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
# warn "2user $user testid $testid resp $responses index1 $index1 prev $responses[$index1-1] next $responses[$index1+1] .\n" ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# warn "index2 $index2 individ $individ[$index2] .\n" ; |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat index2 $index2 scores $scores[$index2] \n" ; |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat No Response \n" ; |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat Response \n" ; |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
$ret ; # Return reference. |
|
||||
} # End of GetLikertData |
|
||||
|
|
||||
sub GetLikertGrpData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $idlist - required Hash reference, keys are candidate ids, values are group id for desired candidates. |
|
||||
# Returned values - $ret_all, $ret_grp |
|
||||
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. Values for candidates will be counted here regardless of |
|
||||
# group membership. |
|
||||
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are |
|
||||
# the group ids. The values are structured like $ret_all. |
|
||||
my ($client, $testid, $idlist) = @_ ; |
|
||||
my $ret_all = {} ; my $ret_grp = {} ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
my $inact_ques = 0; # Count of the inactive questions found. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
unless (defined $idlist ) { |
|
||||
warn "In GetLikertData and idlist is undefined." ; |
|
||||
} |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
my $user_grp = undef ; |
|
||||
# Process this desired candidate's test answers. |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
if (defined $idlist and %{$idlist} and $idlist->{$user}) { |
|
||||
unless (defined $ret_grp->{$idlist->{$user}}->{$supercat}) { |
|
||||
# warn "Init grp Cat $supercat user $user Grp $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
} |
|
||||
} |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
# warn "ADD USER $user GRP $idlist->{$user} PNTS $points TOT $ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'}" if $supercat eq "Employee Passion" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
unless (exists $ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
# warn "CHECKING CAT $supercat USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} ++ ; |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} ++ ; |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
return ($ret, $ret_grp) ; # Return reference. |
|
||||
} # End of GetLikertGrpData |
|
||||
|
|
||||
sub GetFullLikertGrpData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $grplist - optional Hash reference, keys are group ids, values are like getGroups function. |
|
||||
# if undef. then only one returned value. |
|
||||
# $grp_req - optional boolean, default is false. If true, then $ret_all only includes results |
|
||||
# for users in the $grplist, and $grplist must be provided to get any results. |
|
||||
|
|
||||
# Returned values - $ret_all, $ret_grp |
|
||||
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', 'ScoreCount', and 'Questions'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. Values for candidates will be counted here regardless of |
|
||||
# group membership. The value of 'Questions' is an un-named hash. The keys of the un-named |
|
||||
# hash are the question numbers for the supercategory. The value is always 1. |
|
||||
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are |
|
||||
# the group ids. The values are structured like $ret_all. This is not returned if |
|
||||
# the parameter $grplist is not provided, or undef. |
|
||||
|
|
||||
my ($client, $testid, $grplist,$grp_req) = @_ ; |
|
||||
# warn "grplist" ; |
|
||||
# warn &Dumper(\$grplist) ; |
|
||||
# warn "grp_req $grp_req X\n" ; |
|
||||
my $ret_all = {} ; my $ret_grp = {} ; |
|
||||
my %Group_Xref = () ; # List of groups that each member belongs to. |
|
||||
# The hash key is a member id, the value is an array of the groups he is in. |
|
||||
# Build the cross reference. |
|
||||
my $Group = "" ; my $Member = "" ; |
|
||||
foreach $Group (keys %{${grplist}}) { |
|
||||
foreach $Member (@{${grplist}->{$Group}->{'grplist'}}) { |
|
||||
push @{$Group_Xref->{$Member}} , $Group ; |
|
||||
} |
|
||||
} |
|
||||
# warn Dumper(\%Group_Xref) ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
my $user_grp = undef ; |
|
||||
my $inact_ques = 0; # Count of the inactive questions found. |
|
||||
# Do not process this user if group membership is required and not a member. |
|
||||
if ($grp_req and not $Group_Xref->{$user}) { |
|
||||
# warn "Skipped User $user X" ; |
|
||||
next ; |
|
||||
} |
|
||||
# Process this desired candidate's test answers. |
|
||||
# warn "Process User $user X" ; |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$ret->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
my @Groups = @{$Group_Xref->{$user}} ; |
|
||||
foreach $group (@Groups) { |
|
||||
unless (defined $ret_grp->{$group}->{$supercat}) { |
|
||||
# warn "Init all Cat $supercat Group $group.\n" if $supercat eq "Improvement" ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
} |
|
||||
} # foreach $group |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
} |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
unless (exists $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
# warn "CHECKING CAT $supercat USER $user GRP @group RESP $responses \n" if $supercat eq "Improvement" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP @group \n" if $supercat eq "Improvement" ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
} |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'NoResponses'} ++ ; |
|
||||
} |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'Responses'} ++ ; |
|
||||
} |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
return ($ret, $ret_grp) ; # Return reference. |
|
||||
} # End of GetFullLikertGrpData |
|
||||
|
|
||||
sub BuildBarGraph { |
|
||||
# This subroutine builds the HTML to get an image from an URL. |
|
||||
# The URL is a cgi-bin PERL script, with several parameters. |
|
||||
# The list parameters are: labels, values, and values2. |
|
||||
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin |
|
||||
|
|
||||
# The first 3 parameters are references to three lists, which are mandatory. |
|
||||
# The values2 list may be an empty list. (and ignored.) |
|
||||
# The rest of the parameters are optional, but are order specific. |
|
||||
# Any parameter that is an empty string will be effectively ignored, |
|
||||
# but may be required to fill the list of parameters to a needed parm. |
|
||||
my @label_names, @value_points, @value2_points ; |
|
||||
my $labels_ref, $values_ref, $values2_ref ; |
|
||||
my $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum ; |
|
||||
my $colorscheme ; |
|
||||
my $t_margin, $b_margin, $l_margin, $r_margin ; |
|
||||
$labels_ref = $_[0] ; |
|
||||
@label_names = @{$labels_ref} ; |
|
||||
# @label_names is an array of character strings of the names of the bars on the graph. |
|
||||
$values_ref = $_[1] ; |
|
||||
@value_points = @{$values_ref} ; |
|
||||
# @value_points is an array of numeric values for each of the names in the first array. |
|
||||
# The sizes of the two arrays should be the same. |
|
||||
$values2_ref = $_[2] ; |
|
||||
@value2_points = @{$values2_ref} ; |
|
||||
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement. |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ; |
|
||||
my $labels, $values, $values2 ; |
|
||||
# print '<br> label_names ' . "@label_names" . ' <br>' ; |
|
||||
# print '<br> value_points ' . "@value_points" . ' <br>' ; |
|
||||
if ($#label_names != $#value_points) { |
|
||||
print '<br>ERROR BuildBarGraph has different number of labels and data values.<br>' ; |
|
||||
} |
|
||||
$labels = join (":", map {munge($_)} @label_names ) ; |
|
||||
$values = join (":", map {munge($_)} @value_points ) ; |
|
||||
$values2 = join (":", map {munge($_)} @value2_points ) ; |
|
||||
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents"; |
|
||||
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ; |
|
||||
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; } |
|
||||
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; } |
|
||||
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; } |
|
||||
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; } |
|
||||
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; } |
|
||||
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; } |
|
||||
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; } |
|
||||
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; } |
|
||||
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; } |
|
||||
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; } |
|
||||
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; } |
|
||||
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; } |
|
||||
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; } |
|
||||
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; } |
|
||||
return "<img src=\"$baseurl&values2=$values2\">"; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
|
|
||||
1 ; # End of Perl Library file |
|
||||
|
|
||||
@ -1,449 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
|
|
||||
# Source - LikertData.pl |
|
||||
|
|
||||
# Svn Keywords |
|
||||
# $Date$ |
|
||||
# $Revision$ |
|
||||
# $Author$ |
|
||||
# $HeadURL$ |
|
||||
# $Id$ |
|
||||
|
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
|
|
||||
require 'questionslib.pl'; |
|
||||
require Exporter; |
|
||||
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); |
|
||||
@ISA = qw(Exporter); |
|
||||
# Items to export into callers namespace by default. Note: do not export |
|
||||
# names by default without a very good reason. Use EXPORT_OK instead. |
|
||||
# Do not simply export all your public functions/methods/constants. |
|
||||
@EXPORT = qw(GetLikertData); |
|
||||
@EXPORT_OK = qw(); |
|
||||
$VERSION = '0.01'; |
|
||||
|
|
||||
sub GetLikertData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $idlist - optional Hash reference, keys are candidate ids, values are true for desired candidates. |
|
||||
# Returned value. |
|
||||
# $ret - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. |
|
||||
my ($client, $testid, $idlist) = @_ ; |
|
||||
my $ret = {} ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
unless (defined $idlist) { |
|
||||
# warn "In GetLikertData and idlist is undefined." ; |
|
||||
} |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
if (defined $idlist and %{$idlist} and not $idlist->{$user}) { |
|
||||
# warn "Skipped completed test for $user ." ; |
|
||||
# warn "Reference " . ref $idlist . " value." ; |
|
||||
next; |
|
||||
} |
|
||||
my $inact_ques = 0 ; # This is an offset for the inactive questions. |
|
||||
# The inactive questions are still listed, but without an answer. |
|
||||
# warn "Process completed test for $user ." ; |
|
||||
# Process this desired candidate's test answers. |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
# warn "user $user testid $testid resp $responses .\n" ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
# warn "2user $user testid $testid resp $responses index1 $index1 prev $responses[$index1-1] next $responses[$index1+1] .\n" ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# warn "index2 $index2 individ $individ[$index2] .\n" ; |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat index2 $index2 scores $scores[$index2] \n" ; |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat No Response \n" ; |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
# warn "Likert Answer supercat $supercat Response \n" ; |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
$ret ; # Return reference. |
|
||||
} # End of GetLikertData |
|
||||
|
|
||||
sub GetLikertGrpData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $idlist - required Hash reference, keys are candidate ids, values are group id for desired candidates. |
|
||||
# Returned values - $ret_all, $ret_grp |
|
||||
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. Values for candidates will be counted here regardless of |
|
||||
# group membership. |
|
||||
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are |
|
||||
# the group ids. The values are structured like $ret_all. |
|
||||
my ($client, $testid, $idlist) = @_ ; |
|
||||
my $ret_all = {} ; my $ret_grp = {} ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
my $inact_ques = 0; # Count of the inactive questions found. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
unless (defined $idlist ) { |
|
||||
warn "In GetLikertData and idlist is undefined." ; |
|
||||
} |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
my $user_grp = undef ; |
|
||||
# Process this desired candidate's test answers. |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
if (defined $idlist and %{$idlist} and $idlist->{$user}) { |
|
||||
unless (defined $ret_grp->{$idlist->{$user}}->{$supercat}) { |
|
||||
# warn "Init grp Cat $supercat user $user Grp $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
} |
|
||||
} |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
# warn "ADD USER $user GRP $idlist->{$user} PNTS $points TOT $ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'}" if $supercat eq "Employee Passion" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
unless (exists $ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
# warn "CHECKING CAT $supercat USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} ++ ; |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} ++ ; |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
return ($ret, $ret_grp) ; # Return reference. |
|
||||
} # End of GetLikertGrpData |
|
||||
|
|
||||
sub GetFullLikertGrpData { |
|
||||
# Parameters |
|
||||
# $client - required String, client id. |
|
||||
# $testid - required String, test id. |
|
||||
# $grplist - optional Hash reference, keys are group ids, values are like getGroups function. |
|
||||
# if undef. then only one returned value. |
|
||||
# $grp_req - optional boolean, default is false. If true, then $ret_all only includes results |
|
||||
# for users in the $grplist, and $grplist must be provided to get any results. |
|
||||
|
|
||||
# Returned values - $ret_all, $ret_grp |
|
||||
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories |
|
||||
# of the likert questions in the test. The keys of the second hash are 'PointsAvail', |
|
||||
# 'Responses', 'NoResponses', 'PointsEarned', 'ScoreCount', and 'Questions'. The values of the first |
|
||||
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is |
|
||||
# another hash. Its keys are the scores, and the values are the counts of the number |
|
||||
# of times each score was a response. Values for candidates will be counted here regardless of |
|
||||
# group membership. The value of 'Questions' is an un-named hash. The keys of the un-named |
|
||||
# hash are the question numbers for the supercategory. The value is always 1. |
|
||||
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are |
|
||||
# the group ids. The values are structured like $ret_all. This is not returned if |
|
||||
# the parameter $grplist is not provided, or undef. |
|
||||
|
|
||||
my ($client, $testid, $grplist,$grp_req) = @_ ; |
|
||||
# warn "grplist" ; |
|
||||
# warn &Dumper(\$grplist) ; |
|
||||
# warn "grp_req $grp_req X\n" ; |
|
||||
my $ret_all = {} ; my $ret_grp = {} ; |
|
||||
my %Group_Xref = () ; # List of groups that each member belongs to. |
|
||||
# The hash key is a member id, the value is an array of the groups he is in. |
|
||||
# Build the cross reference. |
|
||||
my $Group = "" ; my $Member = "" ; |
|
||||
foreach $Group (keys %{${grplist}}) { |
|
||||
foreach $Member (@{${grplist}->{$Group}->{'grplist'}}) { |
|
||||
push @{$Group_Xref->{$Member}} , $Group ; |
|
||||
} |
|
||||
} |
|
||||
# warn Dumper(\%Group_Xref) ; |
|
||||
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes. |
|
||||
&get_test_profile($client, $testid) ; # Populates %TEST |
|
||||
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
# Populates an array of hashs that contains all of the questions and the answers. |
|
||||
# $QUESTIONS_AH is a reference to the arrays of hashs. |
|
||||
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. |
|
||||
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid); |
|
||||
foreach my $file (@filelist) { |
|
||||
my $user = $file; |
|
||||
$user =~ s/.$testid$//; # Strip the test id off the end of the file name. |
|
||||
$user =~ s/^$client.//; # Strip the client id off the start of the file name. |
|
||||
my $user_grp = undef ; |
|
||||
my $inact_ques = 0; # Count of the inactive questions found. |
|
||||
# Do not process this user if group membership is required and not a member. |
|
||||
if ($grp_req and not $Group_Xref->{$user}) { |
|
||||
# warn "Skipped User $user X" ; |
|
||||
next ; |
|
||||
} |
|
||||
# Process this desired candidate's test answers. |
|
||||
# warn "Process User $user X" ; |
|
||||
&get_test_sequence_for_reports($client, $user, $testid) ; |
|
||||
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, |
|
||||
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY. |
|
||||
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; |
|
||||
my $ques_type, $supercat, $scores, @responses, $responses ; |
|
||||
$responses = $SUBTEST_RESPONSES{2} ; |
|
||||
@responses = split (/\&/, $responses) ; |
|
||||
shift @responses ; # Drop the empty element in front of the list. |
|
||||
foreach $index1 (0 .. $last_index) { |
|
||||
# Skip the question if it is inactive. |
|
||||
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;} |
|
||||
# Get the data for a single question. |
|
||||
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; |
|
||||
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; |
|
||||
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; |
|
||||
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; |
|
||||
unless ($ques_type eq "lik") {next ;} |
|
||||
@scores = split (/\,/ , $scores) ; |
|
||||
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; |
|
||||
unless ($supercat_found{$supercat}) { |
|
||||
# Initialize counters. |
|
||||
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
$supercat_found{$supercat} = 1 ; |
|
||||
} |
|
||||
$ret->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ; |
|
||||
my @Groups = @{$Group_Xref->{$user}} ; |
|
||||
foreach $group (@Groups) { |
|
||||
unless (defined $ret_grp->{$group}->{$supercat}) { |
|
||||
# warn "Init all Cat $supercat Group $group.\n" if $supercat eq "Improvement" ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'NoResponses'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'Responses'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} = 0 ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'} = {} ; |
|
||||
} |
|
||||
} # foreach $group |
|
||||
$responses = $responses[$index1-$inact_ques] ; |
|
||||
@individ = split(/\?/, $responses) ; |
|
||||
shift @individ ; |
|
||||
my $no_response = 1 ; |
|
||||
$ret->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ; |
|
||||
} |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
# Add the key for the score count to the hash. |
|
||||
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
unless (exists $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ; |
|
||||
} |
|
||||
} |
|
||||
# warn "CHECKING CAT $supercat USER $user GRP @group RESP $responses \n" if $supercat eq "Improvement" ; |
|
||||
foreach $index2 (0 .. $#scores) { |
|
||||
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { |
|
||||
# Answered this question. |
|
||||
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP @group \n" if $supercat eq "Improvement" ; |
|
||||
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} += $scores[$index2] ; |
|
||||
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ; |
|
||||
} |
|
||||
$no_response = 0 ; |
|
||||
} # If answered. |
|
||||
} # foreach $index2 |
|
||||
if ($no_response) { |
|
||||
# Add to the no response count. |
|
||||
$ret->{$supercat}->{'NoResponses'} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'NoResponses'} ++ ; |
|
||||
} |
|
||||
} else { |
|
||||
# Add to the response count. |
|
||||
$ret->{$supercat}->{'Responses'} ++ ; |
|
||||
foreach $group (@Groups) { |
|
||||
$ret_grp->{$group}->{$supercat}->{'Responses'} ++ ; |
|
||||
} |
|
||||
} |
|
||||
} # foreach question. |
|
||||
} # foreach file (i.e. candidate) |
|
||||
return ($ret, $ret_grp) ; # Return reference. |
|
||||
} # End of GetFullLikertGrpData |
|
||||
|
|
||||
sub BuildBarGraph { |
|
||||
# This subroutine builds the HTML to get an image from an URL. |
|
||||
# The URL is a cgi-bin PERL script, with several parameters. |
|
||||
# The list parameters are: labels, values, and values2. |
|
||||
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin |
|
||||
|
|
||||
# The first 3 parameters are references to three lists, which are mandatory. |
|
||||
# The values2 list may be an empty list. (and ignored.) |
|
||||
# The rest of the parameters are optional, but are order specific. |
|
||||
# Any parameter that is an empty string will be effectively ignored, |
|
||||
# but may be required to fill the list of parameters to a needed parm. |
|
||||
my @label_names, @value_points, @value2_points ; |
|
||||
my $labels_ref, $values_ref, $values2_ref ; |
|
||||
my $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum ; |
|
||||
my $colorscheme ; |
|
||||
my $t_margin, $b_margin, $l_margin, $r_margin ; |
|
||||
$labels_ref = $_[0] ; |
|
||||
@label_names = @{$labels_ref} ; |
|
||||
# @label_names is an array of character strings of the names of the bars on the graph. |
|
||||
$values_ref = $_[1] ; |
|
||||
@value_points = @{$values_ref} ; |
|
||||
# @value_points is an array of numeric values for each of the names in the first array. |
|
||||
# The sizes of the two arrays should be the same. |
|
||||
$values2_ref = $_[2] ; |
|
||||
@value2_points = @{$values2_ref} ; |
|
||||
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement. |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ; |
|
||||
my $labels, $values, $values2 ; |
|
||||
# print '<br> label_names ' . "@label_names" . ' <br>' ; |
|
||||
# print '<br> value_points ' . "@value_points" . ' <br>' ; |
|
||||
if ($#label_names != $#value_points) { |
|
||||
print '<br>ERROR BuildBarGraph has different number of labels and data values.<br>' ; |
|
||||
} |
|
||||
$labels = join (":", map {munge($_)} @label_names ) ; |
|
||||
$values = join (":", map {munge($_)} @value_points ) ; |
|
||||
$values2 = join (":", map {munge($_)} @value2_points ) ; |
|
||||
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents"; |
|
||||
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ; |
|
||||
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; } |
|
||||
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; } |
|
||||
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; } |
|
||||
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; } |
|
||||
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; } |
|
||||
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; } |
|
||||
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; } |
|
||||
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; } |
|
||||
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; } |
|
||||
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; } |
|
||||
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; } |
|
||||
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; } |
|
||||
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; } |
|
||||
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; } |
|
||||
return "<img src=\"$baseurl&values2=$values2\">"; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
|
|
||||
1 ; # End of Perl Library file |
|
||||
|
|
||||
@ -1,488 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: Likert_Gen_Groups.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'LikertData.pl' ; |
|
||||
require 'grepa.pm' ; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES @xlatphrase); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); |
|
||||
use vars qw($testinprog $testpending) ; |
|
||||
|
|
||||
# &app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
# print STDERR Dumper(\%FORM); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
# warn "Tstid $FORM{'tstid'}\n" ; |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
# print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'LikertWQ') { |
|
||||
&LikertWQ($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'LikertWQG') { |
|
||||
&LikertWQG($idlist, $groups, $timestamp); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<!--Integro3.pl-->\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
my $ionline; |
|
||||
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") { |
|
||||
$ionline = "<br>Copyright (c) $year, Integro Learning Company"; |
|
||||
} |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
my $organizationname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; |
|
||||
# print STDERR Dumper($TESTS) ; |
|
||||
my %TESTS = %$TESTS ; |
|
||||
my @test_list = () ; |
|
||||
my $ids ; |
|
||||
for $ids (keys %TESTS) { |
|
||||
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; |
|
||||
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; |
|
||||
} |
|
||||
# warn "test_list count $#test_list X\n" ; |
|
||||
# print STDERR Dumper(\@test_list) ; |
|
||||
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; |
|
||||
|
|
||||
#print STDERR get_data("tests.$CLIENT{'clid'}"); |
|
||||
#print STDERR "Test ID = $tstid\n"; |
|
||||
print HTMLHeader("Integro Learning Custom Reports",$js . $js1); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border>\n<caption>Integro Learning Custom Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</select>\n"; |
|
||||
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print $test_choice_html ; |
|
||||
print "<p>Likert Scale Report" ; |
|
||||
print "<ul style=\"list-style: none\">" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is zero, Question Numbers listed.</li>\n" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Likert Scale by Group</a> - No Response is zero, Detail by Groups.</li>\n" ; |
|
||||
print "</ul></p>\n" ; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
print "</form>"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQ { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or the Groups selected. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale General Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale General Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"5\">Category Scores</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
print "<tr>" ; |
|
||||
print "<th>Category</th>" ; |
|
||||
print "<th>Questions</th>" ; |
|
||||
print "<th>Points Possible</th>" ; |
|
||||
print "<th>Points Earned</th>" ; |
|
||||
print "<th>% Earned</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
my $supercat ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
$questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print "<tr>" ; |
|
||||
print "<th>$supercat</th>" ; |
|
||||
print "<td>$questions</td>" ; |
|
||||
print "<td>$possible</td>" ; |
|
||||
print &rep_cell_str($earned, $possible) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
|
|
||||
# Print Total row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"2\">Total</th>" ; |
|
||||
print "<td>$tot_poss</td>" ; |
|
||||
print &rep_cell_str($tot_earned, $tot_poss) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
print "</tr>\n" ; |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQG { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or just groups, and lists group results. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale Group Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale Group Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
my $cat_count = keys %{$sumdata} ; # Number of categories. |
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th ></th>" ; |
|
||||
my $supercat ; |
|
||||
foreach $supercat (sort keys %{$sumdata}) { |
|
||||
print "<th >$supercat</th>\n" ; |
|
||||
} |
|
||||
print "<th >Total</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
print "<tr>" ; |
|
||||
print "<td >Overall</td >\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
# my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print heading for Groups. |
|
||||
my $col_count = $cat_count + 2 ; |
|
||||
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" ; |
|
||||
|
|
||||
print "<tr><th >Supervisor</th >" ; |
|
||||
for $supercat (@supercats) { |
|
||||
print "<th >$supercat</th >" ; |
|
||||
} |
|
||||
print "<th >Total</th ></tr >\n" ; |
|
||||
|
|
||||
unless ($grpdata) { |
|
||||
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" ; |
|
||||
} else { |
|
||||
my $group ; |
|
||||
foreach $group (sort keys %{$grpdata}) { |
|
||||
if ($group) { |
|
||||
print "<tr >" ; |
|
||||
print "<td >" ; |
|
||||
# print "$group " ; |
|
||||
print $all_groups->{$group}->{'grpnme'} ; |
|
||||
print "</td >" ; |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; |
|
||||
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub rep_cell_str { |
|
||||
# Parameters |
|
||||
# $count - required, number for the cell, integer. |
|
||||
# $total - dividend for the percent, integer. |
|
||||
# $skip_tot - Optional, default false. |
|
||||
# If true, do not print total. |
|
||||
# Returned Value |
|
||||
# $html_str - html string to print for the cell. |
|
||||
my ($count, $total, $skip_tot) = @_ ; |
|
||||
my $html_str ; |
|
||||
$html_str .= "<td align=\"center\">" unless ($skip_tot) ; |
|
||||
my ($percent, $percent_str, $count_str) ; |
|
||||
$count_str = sprintf("%4i", $count) ; |
|
||||
if ($total == 0) { |
|
||||
# total is 0, percent is undefined. |
|
||||
$percent_str = "- - %" ; |
|
||||
} else { |
|
||||
$percent = 100.0 * $count / $total ; |
|
||||
$percent_str = sprintf("%5.1f %%", $percent) ; |
|
||||
} |
|
||||
$html_str .= "$count_str</td>" unless ($skip_tot) ; |
|
||||
$html_str .= "<td align=\"right\">" ; |
|
||||
$html_str .= "$percent_str</td>" ; |
|
||||
return $html_str ; |
|
||||
} |
|
||||
|
|
||||
sub ret_test_chooser_mod { |
|
||||
# Return strings of html to pick a survey. |
|
||||
# The parameter is an array of arrays with test descriptions and ids. |
|
||||
# The returned value is an array with two strings. |
|
||||
# The first string is JavaScript for the test chooser. |
|
||||
# The second string is html for the tables to drive the test chooser. |
|
||||
my @trecs = @_; |
|
||||
# print STDERR Dumper(\@trecs) ; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $html_str = "" ; |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) ; |
|
||||
$desc = $trecs[$_][0] ; |
|
||||
$id = $trecs[$_][1] ; |
|
||||
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
my $radio_tst_button ; |
|
||||
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id . |
|
||||
'" > ' . $id ; |
|
||||
$tstoption = " <TR>" . |
|
||||
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" . |
|
||||
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" . |
|
||||
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" . |
|
||||
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" . |
|
||||
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" . |
|
||||
# "</form>" . |
|
||||
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"<TR>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" . |
|
||||
"</TR>" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
$tstoptions . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"</TABLE> " ; |
|
||||
return ($js, $html_str) ; |
|
||||
} |
|
||||
|
|
||||
@ -1,508 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: Likert_Gen_Groups.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'LikertData.pl' ; |
|
||||
require 'grepa.pm' ; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES @xlatphrase); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); |
|
||||
use vars qw($testinprog $testpending) ; |
|
||||
|
|
||||
# &app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
# print STDERR Dumper(\%FORM); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
# warn "Tstid $FORM{'tstid'}\n" ; |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
# print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'LikertWQ') { |
|
||||
&LikertWQ($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'LikertWQG') { |
|
||||
&LikertWQG($idlist, $groups, $timestamp); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<!--Integro3.pl-->\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
my $ionline; |
|
||||
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") { |
|
||||
$ionline = "<br>Copyright (c) $year, Integro Learning Company"; |
|
||||
} |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
my $organizationname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; |
|
||||
# print STDERR Dumper($TESTS) ; |
|
||||
my %TESTS = %$TESTS ; |
|
||||
my @test_list = () ; |
|
||||
my $ids ; |
|
||||
for $ids (keys %TESTS) { |
|
||||
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; |
|
||||
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; |
|
||||
} |
|
||||
# warn "test_list count $#test_list X\n" ; |
|
||||
# print STDERR Dumper(\@test_list) ; |
|
||||
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; |
|
||||
|
|
||||
#print STDERR get_data("tests.$CLIENT{'clid'}"); |
|
||||
#print STDERR "Test ID = $tstid\n"; |
|
||||
print HTMLHeader("Integro Learning Custom Reports",$js . $js1); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border>\n<caption>Integro Learning Custom Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</select>\n"; |
|
||||
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print $test_choice_html ; |
|
||||
print "<p>Likert Scale Report" ; |
|
||||
print "<ul style=\"list-style: none\">" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is zero, Question Numbers listed.</li>\n" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Likert Scale by Group</a> - No Response is zero, Detail by Groups.</li>\n" ; |
|
||||
print "</ul></p>\n" ; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
print "</form>"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQ { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or the Groups selected. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale General Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale General Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
my (@img_labels, @img_data) ; |
|
||||
my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ; |
|
||||
my ($colorscheme, $t_margin, $b_margin, $l_margin, $r_margin ) ; |
|
||||
@img_labels = () ; @img_data = () ; @values2 = () ; |
|
||||
($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ; |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) = |
|
||||
(800, 100, 1, "$CLIENT{'clnmc'}", "Category", "Percent for Category", 100, 0, 10, 1) ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"5\">Category Scores</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
print "<tr>" ; |
|
||||
print "<th>Category</th>" ; |
|
||||
print "<th>Questions</th>" ; |
|
||||
print "<th>Points Possible</th>" ; |
|
||||
print "<th>Points Earned</th>" ; |
|
||||
print "<th>% Earned</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
my $supercat ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
$questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print "<tr>" ; |
|
||||
print "<th>$supercat</th>" ; |
|
||||
print "<td>$questions</td>" ; |
|
||||
print "<td>$possible</td>" ; |
|
||||
print &rep_cell_str($earned, $possible) ; |
|
||||
push @img_labels, $supercat ; |
|
||||
my ($percent) = int ((100.0 * $earned / $possible) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
|
|
||||
# Print Total row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"2\">Total</th>" ; |
|
||||
print "<td>$tot_poss</td>" ; |
|
||||
print &rep_cell_str($tot_earned, $tot_poss) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
print "</tr>\n" ; |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
if (@supercats) { |
|
||||
print "<br><br>\n" ; |
|
||||
print BuildBarGraph(\@img_labels, \@img_data, \@values2, $xdim, |
|
||||
$ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, |
|
||||
$colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) ; |
|
||||
print "<br><br>\n" ; |
|
||||
} |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQG { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or just groups, and lists group results. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale Group Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale Group Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
my $cat_count = keys %{$sumdata} ; # Number of categories. |
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th ></th>" ; |
|
||||
my $supercat ; |
|
||||
foreach $supercat (sort keys %{$sumdata}) { |
|
||||
print "<th >$supercat</th>\n" ; |
|
||||
} |
|
||||
print "<th >Total</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
print "<tr>" ; |
|
||||
print "<td >Overall</td >\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
# my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print heading for Groups. |
|
||||
my $col_count = $cat_count + 2 ; |
|
||||
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" ; |
|
||||
|
|
||||
print "<tr><th >Supervisor</th >" ; |
|
||||
for $supercat (@supercats) { |
|
||||
print "<th >$supercat</th >" ; |
|
||||
} |
|
||||
print "<th >Total</th ></tr >\n" ; |
|
||||
|
|
||||
unless ($grpdata) { |
|
||||
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" ; |
|
||||
} else { |
|
||||
my $group ; |
|
||||
foreach $group (sort keys %{$grpdata}) { |
|
||||
if ($group) { |
|
||||
print "<tr >" ; |
|
||||
print "<td >" ; |
|
||||
# print "$group " ; |
|
||||
print $all_groups->{$group}->{'grpnme'} ; |
|
||||
print "</td >" ; |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; |
|
||||
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub rep_cell_str { |
|
||||
# Parameters |
|
||||
# $count - required, number for the cell, integer. |
|
||||
# $total - dividend for the percent, integer. |
|
||||
# $skip_tot - Optional, default false. |
|
||||
# If true, do not print total. |
|
||||
# Returned Value |
|
||||
# $html_str - html string to print for the cell. |
|
||||
my ($count, $total, $skip_tot) = @_ ; |
|
||||
my $html_str ; |
|
||||
$html_str .= "<td align=\"center\">" unless ($skip_tot) ; |
|
||||
my ($percent, $percent_str, $count_str) ; |
|
||||
$count_str = sprintf("%4i", $count) ; |
|
||||
if ($total == 0) { |
|
||||
# total is 0, percent is undefined. |
|
||||
$percent_str = "- - %" ; |
|
||||
} else { |
|
||||
$percent = 100.0 * $count / $total ; |
|
||||
$percent_str = sprintf("%5.1f %%", $percent) ; |
|
||||
} |
|
||||
$html_str .= "$count_str</td>" unless ($skip_tot) ; |
|
||||
$html_str .= "<td align=\"right\">" ; |
|
||||
$html_str .= "$percent_str</td>" ; |
|
||||
return $html_str ; |
|
||||
} |
|
||||
|
|
||||
sub ret_test_chooser_mod { |
|
||||
# Return strings of html to pick a survey. |
|
||||
# The parameter is an array of arrays with test descriptions and ids. |
|
||||
# The returned value is an array with two strings. |
|
||||
# The first string is JavaScript for the test chooser. |
|
||||
# The second string is html for the tables to drive the test chooser. |
|
||||
my @trecs = @_; |
|
||||
# print STDERR Dumper(\@trecs) ; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $html_str = "" ; |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) ; |
|
||||
$desc = $trecs[$_][0] ; |
|
||||
$id = $trecs[$_][1] ; |
|
||||
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
my $radio_tst_button ; |
|
||||
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id . |
|
||||
'" > ' . $id ; |
|
||||
$tstoption = " <TR>" . |
|
||||
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" . |
|
||||
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" . |
|
||||
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" . |
|
||||
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" . |
|
||||
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" . |
|
||||
# "</form>" . |
|
||||
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"<TR>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" . |
|
||||
"</TR>" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
$tstoptions . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"</TABLE> " ; |
|
||||
return ($js, $html_str) ; |
|
||||
} |
|
||||
|
|
||||
@ -1,515 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: Likert_Gen_Groups.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'LikertData.pl' ; |
|
||||
require 'grepa.pm' ; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES @xlatphrase); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); |
|
||||
use vars qw($testinprog $testpending) ; |
|
||||
|
|
||||
# &app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
# print STDERR Dumper(\%FORM); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
# warn "Tstid $FORM{'tstid'}\n" ; |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
# print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'LikertWQ') { |
|
||||
&LikertWQ($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'LikertWQG') { |
|
||||
&LikertWQG($idlist, $groups, $timestamp); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<!--Integro3.pl-->\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
my $ionline; |
|
||||
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") { |
|
||||
$ionline = "<br>Copyright (c) $year, Integro Learning Company"; |
|
||||
} |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
my $organizationname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; |
|
||||
# print STDERR Dumper($TESTS) ; |
|
||||
my %TESTS = %$TESTS ; |
|
||||
my @test_list = () ; |
|
||||
my $ids ; |
|
||||
for $ids (keys %TESTS) { |
|
||||
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; |
|
||||
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; |
|
||||
} |
|
||||
# warn "test_list count $#test_list X\n" ; |
|
||||
# print STDERR Dumper(\@test_list) ; |
|
||||
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; |
|
||||
|
|
||||
#print STDERR get_data("tests.$CLIENT{'clid'}"); |
|
||||
#print STDERR "Test ID = $tstid\n"; |
|
||||
print HTMLHeader("Integro Learning Custom Reports",$js . $js1); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border>\n<caption>Integro Learning Custom Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</select>\n"; |
|
||||
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print $test_choice_html ; |
|
||||
print "<p>Likert Scale Report" ; |
|
||||
print "<ul style=\"list-style: none\">" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is zero, Question Numbers listed.</li>\n" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Likert Scale by Group</a> - No Response is zero, Detail by Groups.</li>\n" ; |
|
||||
print "</ul></p>\n" ; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
print "</form>"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQ { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or the Groups selected. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale General Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale General Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
my (@img_labels, @img_data) ; |
|
||||
my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ; |
|
||||
my ($colorscheme, $t_margin, $b_margin, $l_margin, $r_margin ) ; |
|
||||
@img_labels = () ; @img_data = () ; @values2 = () ; |
|
||||
($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ; |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) = |
|
||||
(800, 100, 1, "$CLIENT{'clnmc'}", "Category", "Percent for Category", 100, 0, 10, 1) ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"5\">Category Scores</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
print "<tr>" ; |
|
||||
print "<th>Category</th>" ; |
|
||||
print "<th>Questions</th>" ; |
|
||||
print "<th>Points Possible</th>" ; |
|
||||
print "<th>Points Earned</th>" ; |
|
||||
print "<th>% Earned</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
my $supercat ; my $text_summ = "<p align=left>Category: Percent<br>\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
$questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print "<tr>" ; |
|
||||
print "<th>$supercat</th>" ; |
|
||||
print "<td>$questions</td>" ; |
|
||||
print "<td>$possible</td>" ; |
|
||||
print &rep_cell_str($earned, $possible) ; |
|
||||
push @img_labels, $supercat ; |
|
||||
my ($percent) = int ((100.0 * $earned / $possible) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= $supercat . ": " . $percent . "<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
|
|
||||
# Print Total row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"2\">Total</th>" ; |
|
||||
print "<td>$tot_poss</td>" ; |
|
||||
push @img_labels, "Total" ; |
|
||||
my ($percent) = int ((100.0 * $tot_earned / $tot_poss) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= "Total" . ": " . $percent . "<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print &rep_cell_str($tot_earned, $tot_poss) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
print "</tr>\n" ; |
|
||||
print "</table>\n" ; |
|
||||
print $text_summ ; |
|
||||
|
|
||||
if (@supercats) { |
|
||||
print "<br><br>\n" ; |
|
||||
print BuildBarGraph(\@img_labels, \@img_data, \@values2, $xdim, |
|
||||
$ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, |
|
||||
$colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) ; |
|
||||
print "<br><br>\n" ; |
|
||||
} |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQG { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or just groups, and lists group results. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale Group Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale Group Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
my $cat_count = keys %{$sumdata} ; # Number of categories. |
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th ></th>" ; |
|
||||
my $supercat ; |
|
||||
foreach $supercat (sort keys %{$sumdata}) { |
|
||||
print "<th >$supercat</th>\n" ; |
|
||||
} |
|
||||
print "<th >Total</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
print "<tr>" ; |
|
||||
print "<td >Overall</td >\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
# my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print heading for Groups. |
|
||||
my $col_count = $cat_count + 2 ; |
|
||||
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" ; |
|
||||
|
|
||||
print "<tr><th >Supervisor</th >" ; |
|
||||
for $supercat (@supercats) { |
|
||||
print "<th >$supercat</th >" ; |
|
||||
} |
|
||||
print "<th >Total</th ></tr >\n" ; |
|
||||
|
|
||||
unless ($grpdata) { |
|
||||
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" ; |
|
||||
} else { |
|
||||
my $group ; |
|
||||
foreach $group (sort keys %{$grpdata}) { |
|
||||
if ($group) { |
|
||||
print "<tr >" ; |
|
||||
print "<td >" ; |
|
||||
# print "$group " ; |
|
||||
print $all_groups->{$group}->{'grpnme'} ; |
|
||||
print "</td >" ; |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; |
|
||||
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub rep_cell_str { |
|
||||
# Parameters |
|
||||
# $count - required, number for the cell, integer. |
|
||||
# $total - dividend for the percent, integer. |
|
||||
# $skip_tot - Optional, default false. |
|
||||
# If true, do not print total. |
|
||||
# Returned Value |
|
||||
# $html_str - html string to print for the cell. |
|
||||
my ($count, $total, $skip_tot) = @_ ; |
|
||||
my $html_str ; |
|
||||
$html_str .= "<td align=\"center\">" unless ($skip_tot) ; |
|
||||
my ($percent, $percent_str, $count_str) ; |
|
||||
$count_str = sprintf("%4i", $count) ; |
|
||||
if ($total == 0) { |
|
||||
# total is 0, percent is undefined. |
|
||||
$percent_str = "- - %" ; |
|
||||
} else { |
|
||||
$percent = 100.0 * $count / $total ; |
|
||||
$percent_str = sprintf("%5.1f %%", $percent) ; |
|
||||
} |
|
||||
$html_str .= "$count_str</td>" unless ($skip_tot) ; |
|
||||
$html_str .= "<td align=\"right\">" ; |
|
||||
$html_str .= "$percent_str</td>" ; |
|
||||
return $html_str ; |
|
||||
} |
|
||||
|
|
||||
sub ret_test_chooser_mod { |
|
||||
# Return strings of html to pick a survey. |
|
||||
# The parameter is an array of arrays with test descriptions and ids. |
|
||||
# The returned value is an array with two strings. |
|
||||
# The first string is JavaScript for the test chooser. |
|
||||
# The second string is html for the tables to drive the test chooser. |
|
||||
my @trecs = @_; |
|
||||
# print STDERR Dumper(\@trecs) ; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $html_str = "" ; |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) ; |
|
||||
$desc = $trecs[$_][0] ; |
|
||||
$id = $trecs[$_][1] ; |
|
||||
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
my $radio_tst_button ; |
|
||||
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id . |
|
||||
'" > ' . $id ; |
|
||||
$tstoption = " <TR>" . |
|
||||
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" . |
|
||||
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" . |
|
||||
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" . |
|
||||
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" . |
|
||||
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" . |
|
||||
# "</form>" . |
|
||||
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"<TR>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" . |
|
||||
"</TR>" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
$tstoptions . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"</TABLE> " ; |
|
||||
return ($js, $html_str) ; |
|
||||
} |
|
||||
|
|
||||
@ -1,517 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: Likert_Gen_Groups.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'LikertData.pl' ; |
|
||||
require 'grepa.pm' ; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES @xlatphrase); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); |
|
||||
use vars qw($testinprog $testpending) ; |
|
||||
|
|
||||
# &app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
# print STDERR Dumper(\%FORM); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
# warn "Tstid $FORM{'tstid'}\n" ; |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
# print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'LikertWQ') { |
|
||||
&LikertWQ($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'LikertWQG') { |
|
||||
&LikertWQG($idlist, $groups, $timestamp); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<!--Integro3.pl-->\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
my $ionline; |
|
||||
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") { |
|
||||
$ionline = "<br>Copyright (c) $year, Integro Learning Company"; |
|
||||
} |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
my $organizationname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; |
|
||||
# print STDERR Dumper($TESTS) ; |
|
||||
my %TESTS = %$TESTS ; |
|
||||
my @test_list = () ; |
|
||||
my $ids ; |
|
||||
for $ids (keys %TESTS) { |
|
||||
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; |
|
||||
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; |
|
||||
} |
|
||||
# warn "test_list count $#test_list X\n" ; |
|
||||
# print STDERR Dumper(\@test_list) ; |
|
||||
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; |
|
||||
|
|
||||
#print STDERR get_data("tests.$CLIENT{'clid'}"); |
|
||||
#print STDERR "Test ID = $tstid\n"; |
|
||||
print HTMLHeader("Integro Learning Custom Reports",$js . $js1); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border>\n<caption>Integro Learning Custom Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</select>\n"; |
|
||||
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print $test_choice_html ; |
|
||||
print "<p>Likert Scale Report" ; |
|
||||
print "<ul style=\"list-style: none\">" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is zero, Question Numbers listed.</li>\n" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Likert Scale by Group</a> - No Response is zero, Detail by Groups.</li>\n" ; |
|
||||
print "</ul></p>\n" ; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
print "</form>"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQ { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or the Groups selected. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale General Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale General Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
my (@img_labels, @img_data) ; |
|
||||
my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ; |
|
||||
my ($colorscheme, $t_margin, $b_margin, $l_margin, $r_margin ) ; |
|
||||
@img_labels = () ; @img_data = () ; @values2 = () ; |
|
||||
($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ; |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) = |
|
||||
(800, 100, 1, "$CLIENT{'clnmc'}", "Category", "Percent for Category", 100, 0, 10, 1) ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"5\">Category Scores</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
print "<tr>" ; |
|
||||
print "<th>Category</th>" ; |
|
||||
print "<th>Questions</th>" ; |
|
||||
print "<th>Points Possible</th>" ; |
|
||||
print "<th>Points Earned</th>" ; |
|
||||
print "<th>% Earned</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
my $supercat ; my $text_summ = "<p align=left></b>" ; |
|
||||
$text_summ .= '<font face="Times New Roman, Times New Roman, Times New Roman, Times New Roman" size=3>' ; |
|
||||
$text_summ .= "Category: Percent<br>\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
$questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print "<tr>" ; |
|
||||
print "<th>$supercat</th>" ; |
|
||||
print "<td>$questions</td>" ; |
|
||||
print "<td>$possible</td>" ; |
|
||||
print &rep_cell_str($earned, $possible) ; |
|
||||
push @img_labels, $supercat ; |
|
||||
my ($percent) = int ((100.0 * $earned / $possible) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= $supercat . ": " . $percent . " %<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
|
|
||||
# Print Total row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"2\">Total</th>" ; |
|
||||
print "<td>$tot_poss</td>" ; |
|
||||
push @img_labels, "Total" ; |
|
||||
my ($percent) = int ((100.0 * $tot_earned / $tot_poss) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= "Total" . ": " . $percent . " %<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print &rep_cell_str($tot_earned, $tot_poss) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
print "</tr>\n" ; |
|
||||
print "</table>\n" ; |
|
||||
print $text_summ ; |
|
||||
|
|
||||
if (@supercats) { |
|
||||
print "<br><br>\n" ; |
|
||||
print BuildBarGraph(\@img_labels, \@img_data, \@values2, $xdim, |
|
||||
$ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, |
|
||||
$colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) ; |
|
||||
print "<br><br>\n" ; |
|
||||
} |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQG { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or just groups, and lists group results. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale Group Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale Group Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
my $cat_count = keys %{$sumdata} ; # Number of categories. |
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th ></th>" ; |
|
||||
my $supercat ; |
|
||||
foreach $supercat (sort keys %{$sumdata}) { |
|
||||
print "<th >$supercat</th>\n" ; |
|
||||
} |
|
||||
print "<th >Total</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
print "<tr>" ; |
|
||||
print "<td >Overall</td >\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
# my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print heading for Groups. |
|
||||
my $col_count = $cat_count + 2 ; |
|
||||
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" ; |
|
||||
|
|
||||
print "<tr><th >Supervisor</th >" ; |
|
||||
for $supercat (@supercats) { |
|
||||
print "<th >$supercat</th >" ; |
|
||||
} |
|
||||
print "<th >Total</th ></tr >\n" ; |
|
||||
|
|
||||
unless ($grpdata) { |
|
||||
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" ; |
|
||||
} else { |
|
||||
my $group ; |
|
||||
foreach $group (sort keys %{$grpdata}) { |
|
||||
if ($group) { |
|
||||
print "<tr >" ; |
|
||||
print "<td >" ; |
|
||||
# print "$group " ; |
|
||||
print $all_groups->{$group}->{'grpnme'} ; |
|
||||
print "</td >" ; |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; |
|
||||
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub rep_cell_str { |
|
||||
# Parameters |
|
||||
# $count - required, number for the cell, integer. |
|
||||
# $total - dividend for the percent, integer. |
|
||||
# $skip_tot - Optional, default false. |
|
||||
# If true, do not print total. |
|
||||
# Returned Value |
|
||||
# $html_str - html string to print for the cell. |
|
||||
my ($count, $total, $skip_tot) = @_ ; |
|
||||
my $html_str ; |
|
||||
$html_str .= "<td align=\"center\">" unless ($skip_tot) ; |
|
||||
my ($percent, $percent_str, $count_str) ; |
|
||||
$count_str = sprintf("%4i", $count) ; |
|
||||
if ($total == 0) { |
|
||||
# total is 0, percent is undefined. |
|
||||
$percent_str = "- - %" ; |
|
||||
} else { |
|
||||
$percent = 100.0 * $count / $total ; |
|
||||
$percent_str = sprintf("%5.1f %%", $percent) ; |
|
||||
} |
|
||||
$html_str .= "$count_str</td>" unless ($skip_tot) ; |
|
||||
$html_str .= "<td align=\"right\">" ; |
|
||||
$html_str .= "$percent_str</td>" ; |
|
||||
return $html_str ; |
|
||||
} |
|
||||
|
|
||||
sub ret_test_chooser_mod { |
|
||||
# Return strings of html to pick a survey. |
|
||||
# The parameter is an array of arrays with test descriptions and ids. |
|
||||
# The returned value is an array with two strings. |
|
||||
# The first string is JavaScript for the test chooser. |
|
||||
# The second string is html for the tables to drive the test chooser. |
|
||||
my @trecs = @_; |
|
||||
# print STDERR Dumper(\@trecs) ; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $html_str = "" ; |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) ; |
|
||||
$desc = $trecs[$_][0] ; |
|
||||
$id = $trecs[$_][1] ; |
|
||||
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
my $radio_tst_button ; |
|
||||
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id . |
|
||||
'" > ' . $id ; |
|
||||
$tstoption = " <TR>" . |
|
||||
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" . |
|
||||
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" . |
|
||||
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" . |
|
||||
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" . |
|
||||
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" . |
|
||||
# "</form>" . |
|
||||
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"<TR>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" . |
|
||||
"</TR>" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
$tstoptions . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"</TABLE> " ; |
|
||||
return ($js, $html_str) ; |
|
||||
} |
|
||||
|
|
||||
@ -1,518 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: Likert_Gen_Groups.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Time::Local; |
|
||||
use Data::Dumper; |
|
||||
use IntegroLib; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'LikertData.pl' ; |
|
||||
require 'grepa.pm' ; |
|
||||
|
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES @xlatphrase); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot @rptparams ); |
|
||||
use vars qw($testinprog $testpending) ; |
|
||||
|
|
||||
# &app_initialize; |
|
||||
|
|
||||
$FORM{"idlist"} =~ tr/\000/,/ ; # Change separator for multiple values from NULL to comma. HBI |
|
||||
|
|
||||
&LanguageSupportInit(); |
|
||||
# print STDERR Dumper(\%FORM); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
# warn "Tstid $FORM{'tstid'}\n" ; |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
|
|
||||
# Get the group filters, if any |
|
||||
my ($idlist,$groups); |
|
||||
if (exists $FORM{'grouping'} and $FORM{'grouping'} eq 'subset') { |
|
||||
#my @tmp = split(/,/,$FORM{'idlist'}); |
|
||||
my @tmp = param('idlist'); |
|
||||
$FORM{'idlist'} = join(',', @tmp); |
|
||||
@{$groups}{@tmp} = @tmp; |
|
||||
$idlist = &getIdlist($CLIENT{'clid'},$FORM{'idlist'}); |
|
||||
} |
|
||||
|
|
||||
# Get the time stamp style |
|
||||
my $timestamp; |
|
||||
if ($FORM{'timestamp'} eq 'currenttime') { |
|
||||
$timestamp = scalar(localtime(time)); |
|
||||
} elsif ($FORM{"timestamp"} eq 'custom' and $FORM{'customtime'} ne '') { |
|
||||
$timestamp = $FORM{'customtime'}; |
|
||||
} elsif ($FORM{'timestamp'} eq 'mostrecent' and $FORM{'tstid'}) { |
|
||||
my $file = join($pathsep,$testcomplete,"$CLIENT{'clid'}.$FORM{'tstid'}.history"); |
|
||||
my $fh = new FileHandle; |
|
||||
if ($fh->open($file)) { |
|
||||
my @history = map([split(/(?:<<>>|&)/,$_,4)],<$fh>); |
|
||||
# print "<pre>".Dumper(\@history)."</pre>"; |
|
||||
if (defined $idlist) { |
|
||||
foreach (reverse @history) { |
|
||||
if (exists $idlist->{$_->[2]}) { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($_->[0]))); |
|
||||
last; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$timestamp = scalar(localtime(toGMSeconds($history[$#history]->[0]))); |
|
||||
} |
|
||||
} else { |
|
||||
print STDERR "Could not open $file in Integro.pl\n"; |
|
||||
} |
|
||||
} |
|
||||
if (defined $timestamp) { |
|
||||
$timestamp = "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$timestamp</b></font><br><BR>\n"; |
|
||||
} else { |
|
||||
$timestamp = "<br>\n"; |
|
||||
} |
|
||||
|
|
||||
# Generate the reports |
|
||||
if ($FORM{'reportname'} eq 'LikertWQ') { |
|
||||
&LikertWQ($idlist, $groups, $timestamp); |
|
||||
} elsif ($FORM{'reportname'} eq 'LikertWQG') { |
|
||||
&LikertWQG($idlist, $groups, $timestamp); |
|
||||
} else { |
|
||||
&ReportChooser(); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub HTMLHeader { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<!--Integro3.pl-->\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\"". |
|
||||
" TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\"". |
|
||||
" VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\">\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLHeaderPlain { |
|
||||
return "<html>\n<head>\n<title>$_[0]</title>\n". |
|
||||
"<script language=\"JavaScript\">\n<!-- \n$_[1]\n -->\n</script>\n</head>\n". |
|
||||
"<BODY>\n"; |
|
||||
} |
|
||||
|
|
||||
sub HTMLFooter { |
|
||||
my $year = `date +%Y`; |
|
||||
my $ionline; |
|
||||
if ($ENV{'SERVER_NAME'} =~ "integroonline.com") { |
|
||||
$ionline = "<br>Copyright (c) $year, Integro Learning Company"; |
|
||||
} |
|
||||
return "<br><center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">Copyright (c) $year, ACTS Corporation$ionline<center></font></body>\n</html>\n"; |
|
||||
} |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
# Links w/javascript for chosing report |
|
||||
# Radio button to choose between all and select group(s) |
|
||||
# Menu box to chose one or more groups |
|
||||
my $groups = &getGroups($CLIENT{'clid'}); |
|
||||
my $js = "function parmsIntegro(oform,rpt) {\n\t". |
|
||||
"oform.reportname.value=rpt;\n\t". |
|
||||
"oform.action='/cgi-bin/creports.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
$js .= "\nfunction commIntegro(oform) {\n\t". |
|
||||
"oform.rptid.value='ACT-C-004';\n\t". |
|
||||
"oform.rptdesc.value='Test Statistics by Test'\n\t". |
|
||||
"oform.action='/cgi-bin/IntegroTS.pl';\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
my $organizationname = $CLIENT{'clnmc'}; |
|
||||
my $uberheader; |
|
||||
my $TESTS = get_data_hash ("tests.$CLIENT{'clid'}") ; |
|
||||
# print STDERR Dumper($TESTS) ; |
|
||||
my %TESTS = %$TESTS ; |
|
||||
my @test_list = () ; |
|
||||
my $ids ; |
|
||||
for $ids (keys %TESTS) { |
|
||||
# warn "ID $ids DATADESC $TESTS{$ids}->{'desc'} X" ; |
|
||||
push @test_list, [$TESTS{$ids}->{'desc'}, $ids] ; |
|
||||
} |
|
||||
# warn "test_list count $#test_list X\n" ; |
|
||||
# print STDERR Dumper(\@test_list) ; |
|
||||
my ($js1, $test_choice_html) = ret_test_chooser_mod(@test_list) ; |
|
||||
|
|
||||
#print STDERR get_data("tests.$CLIENT{'clid'}"); |
|
||||
#print STDERR "Test ID = $tstid\n"; |
|
||||
print HTMLHeader("Integro Learning Custom Reports",$js . $js1); |
|
||||
print "<form name=\"integrorpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
# For development purposes we hardcode the survey id. |
|
||||
# Fix this before production |
|
||||
# print "<input type=hidden name=\"tstid\" value=\"\">\n"; # HBI This had a value of $tstid |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
print "<input type=\"hidden\" name=\"reportname\" value=\"\">\n"; |
|
||||
|
|
||||
print "<center>\n<table border>\n<caption>Integro Learning Custom Reports</Caption>\n". |
|
||||
"<tr><td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"all\" checked>All Groups</td>\n". |
|
||||
"<td valign=\"top\"><input type=\"radio\" name=\"grouping\" value=\"subset\">Choose Groups<br>\n". |
|
||||
"<select name=\"idlist\" onchange='this.form.grouping[1].click();' multiple>\n"; |
|
||||
foreach (sort {$a->{'grpnme'} cmp $b->{'grpnme'}} values %$groups) { |
|
||||
print "<option value=\"$_->{'grpid'}\">$_->{'grpnme'}</option>\n"; |
|
||||
} |
|
||||
print "</select>\n"; |
|
||||
#print "<tr><td colspan=\"2\">$xlatphrase[797] $xlatphrase[279]: <input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td colspan=\"3\"><table border=0><tr><td>Organization Name:</td><td><input type=\"text\" name=\"orgname\" value=\"$organizationname\"></td></tr>\n"; |
|
||||
print "<tr><td>Header Override:</td><td><input type=\"text\" name=\"uberheader\" value=\"$uberheader\"></td></tr></table></tr></td>\n"; |
|
||||
print "<tr><td colspan=\"2\">Time Stamp:<ul style=\"list-style: none\">". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"mostrecent\" checked>Most Recent Survey Taken</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"currenttime\">Current Time</li>". |
|
||||
"<li><input type=\"radio\" name=\"timestamp\" value=\"custom\">Custom Value: ". |
|
||||
"<input type=\"text\" name=\"customtime\"></li></tr></td>"; |
|
||||
print "</table></center>\n"; |
|
||||
print $test_choice_html ; |
|
||||
print "<p>Likert Scale Report" ; |
|
||||
print "<ul style=\"list-style: none\">" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQ');\">Likert Scale</a> - No Response is ignored, Question Numbers listed.</li>\n" ; |
|
||||
print "<li><a href=\"javascript:parmsIntegro(document.integrorpt,'LikertWQG');\">Likert Scale by Group</a> - No Response is ignored, Detail by Groups.</li>\n" ; |
|
||||
print "</ul></p>\n" ; |
|
||||
print "<input type=hidden name=\"testsummary\" value=\"composite\">\n"; |
|
||||
print "<input type=hidden name=\"showcmts\" value=\"donot\">\n"; |
|
||||
print "</form>"; |
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQ { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or the Groups selected. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $ResponseRequired = 1 ; # Do not count a question if it is not responded to. |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required, $ResponseRequired) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale General Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale General Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
my (@img_labels, @img_data) ; |
|
||||
my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ; |
|
||||
my ($colorscheme, $t_margin, $b_margin, $l_margin, $r_margin ) ; |
|
||||
@img_labels = () ; @img_data = () ; @values2 = () ; |
|
||||
($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ; |
|
||||
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) = |
|
||||
(800, 100, 1, "$CLIENT{'clnmc'}", "Category", "Percent for Category", 100, 0, 10, 1) ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"5\">Category Scores</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
print "<tr>" ; |
|
||||
print "<th>Category</th>" ; |
|
||||
print "<th>Questions</th>" ; |
|
||||
print "<th>Points Possible</th>" ; |
|
||||
print "<th>Points Earned</th>" ; |
|
||||
print "<th>% Earned</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
my $supercat ; my $text_summ = "<p align=left></b>" ; |
|
||||
$text_summ .= '<font face="Times New Roman, Times New Roman, Times New Roman, Times New Roman" size=3>' ; |
|
||||
$text_summ .= "Category: Percent<br>\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
$questions = join(", ", sort map { $_ + 1 } keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print "<tr>" ; |
|
||||
print "<th>$supercat</th>" ; |
|
||||
print "<td>$questions</td>" ; |
|
||||
print "<td>$possible</td>" ; |
|
||||
print &rep_cell_str($earned, $possible) ; |
|
||||
push @img_labels, $supercat ; |
|
||||
my ($percent) = int ((100.0 * $earned / $possible) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= $supercat . ": " . $percent . " %<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
|
|
||||
# Print Total row. |
|
||||
print "<tr>" ; |
|
||||
print "<th colspan=\"2\">Total</th>" ; |
|
||||
print "<td>$tot_poss</td>" ; |
|
||||
push @img_labels, "Total" ; |
|
||||
my ($percent) = int ((100.0 * $tot_earned / $tot_poss) +0.5) ; |
|
||||
push @img_data, $percent ; |
|
||||
$text_summ .= "Total" . ": " . $percent . " %<br>\n" ; |
|
||||
$ydim += 15 ; # add length to the chart for another row. |
|
||||
print &rep_cell_str($tot_earned, $tot_poss) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
print "</tr>\n" ; |
|
||||
print "</table>\n" ; |
|
||||
print $text_summ ; |
|
||||
|
|
||||
if (@supercats) { |
|
||||
print "<br><br>\n" ; |
|
||||
print BuildBarGraph(\@img_labels, \@img_data, \@values2, $xdim, |
|
||||
$ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, |
|
||||
$colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) ; |
|
||||
print "<br><br>\n" ; |
|
||||
} |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub LikertWQG { |
|
||||
# This does the Summary on the Likert Scale questions, |
|
||||
# for everybody, or just groups, and lists group results. |
|
||||
# $idlist is the list of candidate ids to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the candidate ids, and the value is 1 for candidates in the choosen groups. |
|
||||
# $groups is the hash of groups to report on. It is undef when all groups (everyone) is choosen. |
|
||||
# It is a reference to a hash. The keys are the group ids, and the values are the group ids. |
|
||||
# $FORM{'idlist'} is a comma separated list of the group ids of the selected groups. |
|
||||
# $FORM{'grouping'} is "subset" when the report should only cover the selected groups. |
|
||||
# $FORM{'grouping'} is "all" when the report should cover everybody. |
|
||||
# HBI - Pick it up here. |
|
||||
my ($idlist,$groups,$timestamp) = @_; |
|
||||
my $ResponseRequired = 1 ; # Do not count questions if there was no response. |
|
||||
my $all_groups = getGroups($CLIENT{'clid'}) ; |
|
||||
my $group_membership_required ; |
|
||||
if ($groups) { |
|
||||
$group_membership_required = 1 ; |
|
||||
my $group_p ; |
|
||||
for $group_p (keys %{$all_groups}) { |
|
||||
unless ($groups->{$group_p}) { |
|
||||
undef $all_groups->{$group_p} ; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$group_membership_required = 0 ; |
|
||||
} |
|
||||
my ($sumdata, $grpdata) = &GetFullLikertGrpData($CLIENT{'clid'},$TEST{'id'},$all_groups, $group_membership_required,$ResponseRequired) ; |
|
||||
# warn "sumdata" ; |
|
||||
# warn &Dumper(\$sumdata) ; |
|
||||
# warn "grpdata" ; |
|
||||
# warn &Dumper(\$grpdata) ; |
|
||||
|
|
||||
print HTMLHeaderPlain("Likert Scale Group Results"); |
|
||||
print "<center><font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"5\">" ; |
|
||||
print "<b>Likert Scale Group Results<br>" ; |
|
||||
print "Survey/Test $TEST{'desc'}</b></font><br><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"4\"><b>Improvement as Perceived by Employees</b></font><br>\n"; |
|
||||
# print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$FORM{'orgname'}</b></font><br>\n"; |
|
||||
if ($FORM{'uberheader'} ne "") { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>".$FORM{'uberheader'}."</b></font><br>\n"; |
|
||||
} elsif (defined $idlist) { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>Summary for Groups: " |
|
||||
.join(", ",map($all_groups->{$_}->{'grpnme'},split(/,/,$FORM{'idlist'})))."</b></font><br>\n" ; |
|
||||
} else { |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"3\"><b>$xlatphrase[798] $xlatphrase[799]</b></font><br>\n"; |
|
||||
} |
|
||||
print $timestamp; |
|
||||
print "<font face=\"Verdana, Arial, Helvetica, sans-serif\" size=\"1\">" ; |
|
||||
|
|
||||
# Print HTML for heading. |
|
||||
print "<b><table border>\n"; |
|
||||
|
|
||||
my $cat_count = keys %{$sumdata} ; # Number of categories. |
|
||||
# Print first row. |
|
||||
print "<tr>" ; |
|
||||
print "<th ></th>" ; |
|
||||
my $supercat ; |
|
||||
foreach $supercat (sort keys %{$sumdata}) { |
|
||||
print "<th >$supercat</th>\n" ; |
|
||||
} |
|
||||
print "<th >Total</th>" ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print second row. Heading for each column. |
|
||||
# Loop for Categories. |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
print "<tr>" ; |
|
||||
print "<td >Overall</td >\n" ; |
|
||||
my @supercats = sort keys %{$sumdata} ; |
|
||||
for $supercat (@supercats) { |
|
||||
# my $questions = "" ; |
|
||||
my $possible = 0 ; |
|
||||
my $earned = 0 ; |
|
||||
# $questions = join(", ", sort keys %{$sumdata->{$supercat}->{'Questions'}}) ; |
|
||||
$possible = $sumdata->{$supercat}->{'PointsAvail'} ; |
|
||||
$earned = $sumdata->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
|
|
||||
# Print heading for Groups. |
|
||||
my $col_count = $cat_count + 2 ; |
|
||||
print "<tr><th colspan=\"${col_count}\">Group Breakdown</th ></tr >\n" ; |
|
||||
|
|
||||
print "<tr><th >Supervisor</th >" ; |
|
||||
for $supercat (@supercats) { |
|
||||
print "<th >$supercat</th >" ; |
|
||||
} |
|
||||
print "<th >Total</th ></tr >\n" ; |
|
||||
|
|
||||
unless ($grpdata) { |
|
||||
print "<tr><td colspan=\"${col_count}\">Pick Groups for more detail</td ></tr >\n" ; |
|
||||
} else { |
|
||||
my $group ; |
|
||||
foreach $group (sort keys %{$grpdata}) { |
|
||||
if ($group) { |
|
||||
print "<tr >" ; |
|
||||
print "<td >" ; |
|
||||
# print "$group " ; |
|
||||
print $all_groups->{$group}->{'grpnme'} ; |
|
||||
print "</td >" ; |
|
||||
my $tot_poss = 0 ; my $tot_earned = 0 ; |
|
||||
for $supercat (@supercats) { |
|
||||
my $possible = $grpdata->{$group}->{$supercat}->{'PointsAvail'} ; |
|
||||
my $earned = $grpdata->{$group}->{$supercat}->{'PointsEarned'} ; |
|
||||
$tot_poss += $possible ; |
|
||||
$tot_earned += $earned ; |
|
||||
print &rep_cell_str($earned, $possible, 1) ; |
|
||||
} |
|
||||
print &rep_cell_str($tot_earned, $tot_poss, 1) ; |
|
||||
print "</tr>\n" ; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "</table>\n" ; |
|
||||
|
|
||||
print HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub rep_cell_str { |
|
||||
# Parameters |
|
||||
# $count - required, number for the cell, integer. |
|
||||
# $total - dividend for the percent, integer. |
|
||||
# $skip_tot - Optional, default false. |
|
||||
# If true, do not print total. |
|
||||
# Returned Value |
|
||||
# $html_str - html string to print for the cell. |
|
||||
my ($count, $total, $skip_tot) = @_ ; |
|
||||
my $html_str ; |
|
||||
$html_str .= "<td align=\"center\">" unless ($skip_tot) ; |
|
||||
my ($percent, $percent_str, $count_str) ; |
|
||||
$count_str = sprintf("%4i", $count) ; |
|
||||
if ($total == 0) { |
|
||||
# total is 0, percent is undefined. |
|
||||
$percent_str = "- - %" ; |
|
||||
} else { |
|
||||
$percent = 100.0 * $count / $total ; |
|
||||
$percent_str = sprintf("%5.1f %%", $percent) ; |
|
||||
} |
|
||||
$html_str .= "$count_str</td>" unless ($skip_tot) ; |
|
||||
$html_str .= "<td align=\"right\">" ; |
|
||||
$html_str .= "$percent_str</td>" ; |
|
||||
return $html_str ; |
|
||||
} |
|
||||
|
|
||||
sub ret_test_chooser_mod { |
|
||||
# Return strings of html to pick a survey. |
|
||||
# The parameter is an array of arrays with test descriptions and ids. |
|
||||
# The returned value is an array with two strings. |
|
||||
# The first string is JavaScript for the test chooser. |
|
||||
# The second string is html for the tables to drive the test chooser. |
|
||||
my @trecs = @_; |
|
||||
# print STDERR Dumper(\@trecs) ; |
|
||||
my ($testscompleted, $testsinprogress, $testspending, $href, $tstoption, $tstoptions); |
|
||||
my $html_str = "" ; |
|
||||
my $js = "function setTest(oform,test) {\n\t". |
|
||||
"oform.tstid.value=test;\n\t". |
|
||||
"oform.submit();\n};\n"; |
|
||||
for (0 .. $#trecs) { |
|
||||
my ($desc,$id) ; |
|
||||
$desc = $trecs[$_][0] ; |
|
||||
$id = $trecs[$_][1] ; |
|
||||
# warn "RET_TEST_CHOOSER_MOD ID $id DESC $desc X" ; |
|
||||
$testscompleted = CountTestFiles($testcomplete,$CLIENT{'clid'},$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, $CLIENT{'clid'},$id); |
|
||||
$testspending = CountTestFiles($testpending, $CLIENT{'clid'},$id); |
|
||||
$href="javascript:setTest(document.testform1,\'$id\')\;"; |
|
||||
my $radio_tst_button ; |
|
||||
$radio_tst_button = '<input type="radio" name="tstid" value="' . $id . |
|
||||
'" > ' . $id ; |
|
||||
$tstoption = " <TR>" . |
|
||||
# "<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$radio_tst_button</FONT></TD>" . |
|
||||
"<TD valign=top><FONT SIZE=2>$desc</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD>" . |
|
||||
"<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> </TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
$html_str = "<CENTER><B>Please choose the survey for which you would like reports:</B><br>" . |
|
||||
# "<form name=\"testform1\" action=\"/cgi-bin/creports.pl\" method=\"Post\">" . |
|
||||
# "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">" . |
|
||||
# "<input type=\"hidden\" name=\"tstid\" value=\"\">" . |
|
||||
# "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">" . |
|
||||
# "</form>" . |
|
||||
"<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\">" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"<TR>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD>" . |
|
||||
"<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD>" . |
|
||||
"<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD>" . |
|
||||
"</TR>" . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
$tstoptions . |
|
||||
"<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR>" . |
|
||||
"</TABLE> " ; |
|
||||
return ($js, $html_str) ; |
|
||||
} |
|
||||
|
|
||||
@ -1,243 +0,0 @@ |
|||||
#!/usr/bin/perl -w |
|
||||
# |
|
||||
# $Id: bargraph_multi.pm |
|
||||
# |
|
||||
|
|
||||
use strict; |
|
||||
package bargraph_multi ; |
|
||||
require Exporter ; |
|
||||
@bargraph_multi::ISA = qw(Exporter) ; |
|
||||
@bargraph_multi::EXPORT = qw(Build_Labeled_X_Axis_Graph_Str Build_Labeled_X_Axis_Graph_Obj) ; |
|
||||
@bargraph_multi::EXPORT_OK = qw( ) ; |
|
||||
use GD; |
|
||||
use GD::Graph::colour; |
|
||||
use GD::Graph::bars; |
|
||||
use GD::Graph::hbars; |
|
||||
use GD::Graph::bars3d; |
|
||||
#use Data::Dumper; |
|
||||
|
|
||||
# This perl code is builds Graphs using the GD::Graph modules. |
|
||||
# This code deals with a non-numeric X-Axis. Each tick on the X-Axis is the name of a group. |
|
||||
# The other style has a numeric X-Axis. |
|
||||
sub Build_Labeled_X_Axis_Graph_Str { |
|
||||
# The parameters are: |
|
||||
# $Data_In - A reference to a list of lists. (aka, Array of Arrays) |
|
||||
# Each of the sublists has the same number of elements. |
|
||||
# An element might be the undef value. |
|
||||
# The first sublist is the names of the groups. |
|
||||
# The other sublists are related to the elements in the $Legend parameter. |
|
||||
# $Legend - A reference to a list. |
|
||||
# Each element of the list is the name of a group. |
|
||||
# The data for each group is a sublist in the $Data_In parameter. |
|
||||
# ---- The rest of the parameters are individual options as scalars: numbers, character strings, or undef. |
|
||||
# The returned value is a list of (reference to the plotted graphical object, and graphic string in the mode. |
|
||||
my ($Data_In, $Legend, $Graphic_Mode, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols |
|
||||
) = @_ ; |
|
||||
my $Graph_Obj = &Build_Labeled_X_Axis_Graph_Obj |
|
||||
($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; |
|
||||
my $Plotted_Str ; |
|
||||
unless (defined $Graph_Obj) { |
|
||||
return (undef, "") ; |
|
||||
} else { |
|
||||
if ($Graphic_Mode =~ m/png/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> png ; |
|
||||
} elsif ($Graphic_Mode =~ m/gif/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> gif ; |
|
||||
} else { |
|
||||
return ($Graphic_Mode, "Unsupported Graphical Mode $Graph_Obj.\n") ; |
|
||||
} |
|
||||
} |
|
||||
return ($Graph_Obj, $Plotted_Str) ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub Build_Labeled_X_Axis_Graph_Obj { |
|
||||
my ($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) = @_ ; |
|
||||
# $colorscheme is a colon seperated string of colors. |
|
||||
my $HBI_Debug_Obj = 0 ; |
|
||||
my $Data_In_sublist ; my $Data_In_cnt = 0 ; |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
warn "INFO: " . __FILE__ . " Legend array len is $#{$Legend}.\n" ; |
|
||||
foreach $Data_In_sublist (@{$Data_In}) { |
|
||||
warn "INFO: Data array len is $#{$Data_In_sublist}.\n" ; |
|
||||
$Data_In_cnt ++ ; |
|
||||
} |
|
||||
warn "INFO: Data array $Data_In_cnt elements.\n" ; |
|
||||
} |
|
||||
|
|
||||
my $graph; |
|
||||
if ($hbar) { |
|
||||
#print STDERR "hbar set\n"; |
|
||||
$graph = GD::Graph::hbars->new($xdim,$ydim); |
|
||||
} else { |
|
||||
$graph = GD::Graph::bars->new($xdim,$ydim); |
|
||||
#print STDERR "hbar not set\n"; |
|
||||
} |
|
||||
my @ret_colour_names_avail = () ; |
|
||||
my %valid_colour_name = () ; |
|
||||
@ret_colour_names_avail = GD::Graph::colour::colour_list(59) ; |
|
||||
for my $clr_name (@ret_colour_names_avail) { |
|
||||
if (defined $clr_name) {$valid_colour_name{$clr_name} = 1;} |
|
||||
} |
|
||||
|
|
||||
# The keys of the hash array valid_colour_name are the known color names. |
|
||||
|
|
||||
# warn $full_colour_list ; |
|
||||
# warn "The number of colours is $#ret_colour_names_avail ." ; |
|
||||
# The colors I found at one time are: pink lbrown lred purple |
|
||||
# dblue lpurple green white gold blue dyellow red lgreen marine |
|
||||
# dred cyan yellow lblue orange lgray dgreen dbrown lyellow |
|
||||
# black gray dpink dgray lorange dpurple |
|
||||
|
|
||||
# Set blue yellow if the colorscheme parameter is 1. |
|
||||
# else use the default. |
|
||||
if ($colorscheme and $colorscheme ==1) { |
|
||||
$graph->set( dclrs => [ qw(blue yellow) ] ); |
|
||||
} elsif ($colorscheme) { |
|
||||
my @new_colors = split /:/ , $colorscheme ; |
|
||||
my $index = 0 ; |
|
||||
my $colors = $graph->get('dclrs'); |
|
||||
my $color ; |
|
||||
foreach $color (@new_colors) { |
|
||||
if ($valid_colour_name{$color} ) { |
|
||||
# warn "Pushed $color ." ; |
|
||||
$colors->[$index] = $color ; |
|
||||
$index ++ ; |
|
||||
} else { |
|
||||
warn "Invalid color $color requested." ; |
|
||||
} |
|
||||
} |
|
||||
# warn "Setting dclrs." ; |
|
||||
$graph->set( dclrs => $colors) ; |
|
||||
# warn "Set dclrs." ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my %opt = ('transparent' => 0, |
|
||||
'x_label_position' => 0.5, |
|
||||
'show_values' => 1, |
|
||||
'y_max_value' => 100, |
|
||||
'overwrite' => 0); |
|
||||
if ($title) {$opt{'title'} = $title;} |
|
||||
if ($xlabel) {$opt{'x_label'} = $xlabel;} |
|
||||
if ($ylabel) {$opt{'y_label'} = $ylabel;} |
|
||||
if ($ymax) {$opt{'y_max_value'} = $ymax;} |
|
||||
if ($ymin) {$opt{'y_min_value'} = $ymin;} |
|
||||
if ($t_margin) {$opt{'t_margin'} = $t_margin;} |
|
||||
if ($b_margin) {$opt{'b_margin'} = $b_margin;} |
|
||||
if ($l_margin) {$opt{'l_margin'} = $l_margin;} |
|
||||
if ($r_margin) {$opt{'r_margin'} = $r_margin;} |
|
||||
if ($yticknum) {$opt{'y_tick_number'} = $yticknum;} |
|
||||
if ($bar_spacing) {$opt{'bar_spacing'} = $bar_spacing;} |
|
||||
if ($bargroup_spacing) {$opt{'bargroup_spacing'} = $bargroup_spacing;} |
|
||||
if ($show_values) {$opt{'show_values'} = $show_values;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position;} |
|
||||
if ($transparent) {$opt{'transparent'} = $transparent;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite;} |
|
||||
if ($interlaced) {$opt{'interlaced'} = $interlaced;} |
|
||||
if ($bgclr) {$opt{'bgclr'} = $bgclr;} |
|
||||
if ($fgclr) {$opt{'fgclr'} = $fgclr;} |
|
||||
if ($boxclr) {$opt{'boxclr'} = $boxclr;} |
|
||||
if ($accentclr) {$opt{'accentclr'} = $accentclr;} |
|
||||
if ($shadowclr) {$opt{'shadowclr'} = $shadowclr;} |
|
||||
if ($shadow_depth) {$opt{'shadow_depth'} = $shadow_depth;} |
|
||||
if ($labelclr) {$opt{'labelclr'} = $labelclr ;} |
|
||||
if ($axislabelclr) {$opt{'axislabelclr'} = $axislabelclr ;} |
|
||||
if ($legendclr) {$opt{'legendclr'} = $legendclr ;} |
|
||||
if ($valuesclr) {$opt{'valuesclr'} = $valuesclr ;} |
|
||||
if ($textclr) {$opt{'textclr'} = $textclr ;} |
|
||||
if ($dclrs) {$opt{'dclrs'} = $dclrs ;} |
|
||||
if ($borderclrs) {$opt{'borderclrs'} = $borderclrs ;} |
|
||||
if ($cycle_clrs) {$opt{'cycle_clrs'} = $cycle_clrs ;} |
|
||||
if ($accent_treshold) {$opt{'accent_treshold'} = $accent_treshold ;} |
|
||||
if ($long_ticks) {$opt{'long_ticks'} = $long_ticks ;} |
|
||||
if ($tick_length) {$opt{'tick_length'} = $tick_length ;} |
|
||||
if ($x_ticks) {$opt{'x_ticks'} = $x_ticks ;} |
|
||||
if ($y_number_format) {$opt{'y_number_format'} = $y_number_format ;} |
|
||||
if ($x_label_skip) {$opt{'x_label_skip'} = $x_label_skip ;} |
|
||||
if ($y_label_skip) {$opt{'y_label_skip'} = $y_label_skip ;} |
|
||||
if ($x_last_label_skip) {$opt{'x_last_label_skip'} = $x_last_label_skip ;} |
|
||||
if ($x_tick_offset) {$opt{'x_tick_offset'} = $x_tick_offset ;} |
|
||||
if ($x_all_ticks) {$opt{'x_all_ticks'} = $x_all_ticks ;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position ;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position ;} |
|
||||
if ($x_labels_vertical) {$opt{'x_labels_vertical'} = $x_labels_vertical ;} |
|
||||
if ($x_plot_values) {$opt{'x_plot_values'} = $x_plot_values ;} |
|
||||
if ($y_plot_values) {$opt{'y_plot_values'} = $y_plot_values ;} |
|
||||
if ($box_axis) {$opt{'box_axis'} = $box_axis ;} |
|
||||
if ($no_axes) {$opt{'no_axes'} = $no_axes ;} |
|
||||
if ($two_axes) {$opt{'two_axes'} = $two_axes ;} |
|
||||
if ($use_axis) {$opt{'use_axis'} = $use_axis ;} |
|
||||
if ($zero_axis) {$opt{'zero_axis'} = $zero_axis ;} |
|
||||
if ($zero_axis_only) {$opt{'zero_axis_only'} = $zero_axis_only ;} |
|
||||
if ($axis_space) {$opt{'axis_space'} = $axis_space ;} |
|
||||
if ($text_space) {$opt{'text_space'} = $text_space ;} |
|
||||
if ($cumulate) {$opt{'cumulate'} = $cumulate ;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite ;} |
|
||||
if ($correct_width) {$opt{'correct_width'} = $correct_width ;} |
|
||||
if ($values_vertical) {$opt{'values_vertical'} = $values_vertical ;} |
|
||||
if ($values_space) {$opt{'values_space'} = $values_space ;} |
|
||||
if ($values_format) {$opt{'values_format'} = $values_format ;} |
|
||||
if ($legend_placement) {$opt{'legend_placement'} = $legend_placement ;} |
|
||||
if ($legend_marker_width) {$opt{'legend_marker_width'} = $legend_marker_width ;} |
|
||||
if ($legend_marker_height) {$opt{'legend_marker_height'} = $legend_marker_height ;} |
|
||||
if ($lg_cols) {$opt{'lg_cols'} = $lg_cols ;} |
|
||||
|
|
||||
if ((defined $Legend) && (ref($Legend) eq "ARRAY") && ($#{${Legend}} >= 0)) { |
|
||||
$graph -> set_legend(@{$Legend}) ; |
|
||||
} else { |
|
||||
warn "ERROR: Empty Legend array passed to XXX." ; |
|
||||
} |
|
||||
|
|
||||
$graph->set(%opt) or die $graph->error; |
|
||||
$graph->set_title_font(gdGiantFont); |
|
||||
$graph->set_x_label_font(gdGiantFont); |
|
||||
$graph->set_y_label_font(gdGiantFont); |
|
||||
$graph->set_x_axis_font(gdGiantFont); |
|
||||
$graph->set_y_axis_font(gdGiantFont); |
|
||||
$graph->set_values_font(gdGiantFont); |
|
||||
$graph->set_legend_font(gdGiantFont); |
|
||||
|
|
||||
my $gd = $graph->plot($Data_In) ; |
|
||||
|
|
||||
return $gd |
|
||||
|
|
||||
} |
|
||||
|
|
||||
1 ; |
|
||||
|
|
||||
@ -1,244 +0,0 @@ |
|||||
#!/usr/bin/perl -w |
|
||||
# |
|
||||
# $Id: bargraph_multi.pm |
|
||||
# |
|
||||
|
|
||||
use strict; |
|
||||
package bargraph_multi ; |
|
||||
require Exporter ; |
|
||||
@bargraph_multi::ISA = qw(Exporter) ; |
|
||||
@bargraph_multi::EXPORT = qw(Build_Labeled_X_Axis_Graph_Str Build_Labeled_X_Axis_Graph_Obj) ; |
|
||||
@bargraph_multi::EXPORT_OK = qw( ) ; |
|
||||
use GD; |
|
||||
use GD::Graph::colour; |
|
||||
use GD::Graph::bars; |
|
||||
use GD::Graph::hbars; |
|
||||
use GD::Graph::bars3d; |
|
||||
#use Data::Dumper; |
|
||||
|
|
||||
# This perl code is builds Graphs using the GD::Graph modules. |
|
||||
# This code deals with a non-numeric X-Axis. Each tick on the X-Axis is the name of a group. |
|
||||
# The other style has a numeric X-Axis. |
|
||||
sub Build_Labeled_X_Axis_Graph_Str { |
|
||||
# The parameters are: |
|
||||
# $Data_In - A reference to a list of lists. (aka, Array of Arrays) |
|
||||
# Each of the sublists has the same number of elements. |
|
||||
# An element might be the undef value. |
|
||||
# The first sublist is the names of the groups. |
|
||||
# The other sublists are related to the elements in the $Legend parameter. |
|
||||
# $Legend - A reference to a list. |
|
||||
# Each element of the list is the name of a group. |
|
||||
# The data for each group is a sublist in the $Data_In parameter. |
|
||||
# ---- The rest of the parameters are individual options as scalars: numbers, character strings, or undef. |
|
||||
# The returned value is a list of (reference to the plotted graphical object, and graphic string in the mode. |
|
||||
my ($Data_In, $Legend, $Graphic_Mode, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols |
|
||||
) = @_ ; |
|
||||
my $Graph_Obj ; |
|
||||
$Graph_Obj = &Build_Labeled_X_Axis_Graph_Obj |
|
||||
($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; |
|
||||
my $Plotted_Str ; |
|
||||
unless (defined $Graph_Obj) { |
|
||||
return (undef, "") ; |
|
||||
} else { |
|
||||
if ($Graphic_Mode =~ m/png/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> png ; |
|
||||
} elsif ($Graphic_Mode =~ m/gif/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> gif ; |
|
||||
} else { |
|
||||
return ($Graphic_Mode, "Unsupported Graphical Mode $Graph_Obj.\n") ; |
|
||||
} |
|
||||
} |
|
||||
return ($Graph_Obj, $Plotted_Str) ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub Build_Labeled_X_Axis_Graph_Obj { |
|
||||
my ($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) = @_ ; |
|
||||
# $colorscheme is a colon seperated string of colors. |
|
||||
my $HBI_Debug_Obj = 0 ; |
|
||||
my $Data_In_sublist ; my $Data_In_cnt = 0 ; |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
warn "INFO: " . __FILE__ . " Legend array len is $#{$Legend}.\n" ; |
|
||||
foreach $Data_In_sublist (@{$Data_In}) { |
|
||||
warn "INFO: Data array len is $#{$Data_In_sublist}.\n" ; |
|
||||
$Data_In_cnt ++ ; |
|
||||
} |
|
||||
warn "INFO: Data array $Data_In_cnt elements.\n" ; |
|
||||
} |
|
||||
|
|
||||
my $graph; |
|
||||
if ($hbar) { |
|
||||
#print STDERR "hbar set\n"; |
|
||||
$graph = GD::Graph::hbars->new($xdim,$ydim); |
|
||||
} else { |
|
||||
$graph = GD::Graph::bars->new($xdim,$ydim); |
|
||||
#print STDERR "hbar not set\n"; |
|
||||
} |
|
||||
my @ret_colour_names_avail = () ; |
|
||||
my %valid_colour_name = () ; |
|
||||
@ret_colour_names_avail = GD::Graph::colour::colour_list(59) ; |
|
||||
for my $clr_name (@ret_colour_names_avail) { |
|
||||
if (defined $clr_name) {$valid_colour_name{$clr_name} = 1;} |
|
||||
} |
|
||||
|
|
||||
# The keys of the hash array valid_colour_name are the known color names. |
|
||||
|
|
||||
# warn $full_colour_list ; |
|
||||
# warn "The number of colours is $#ret_colour_names_avail ." ; |
|
||||
# The colors I found at one time are: pink lbrown lred purple |
|
||||
# dblue lpurple green white gold blue dyellow red lgreen marine |
|
||||
# dred cyan yellow lblue orange lgray dgreen dbrown lyellow |
|
||||
# black gray dpink dgray lorange dpurple |
|
||||
|
|
||||
# Set blue yellow if the colorscheme parameter is 1. |
|
||||
# else use the default. |
|
||||
if ($colorscheme and $colorscheme ==1) { |
|
||||
$graph->set( dclrs => [ qw(blue yellow) ] ); |
|
||||
} elsif ($colorscheme) { |
|
||||
my @new_colors = split /:/ , $colorscheme ; |
|
||||
my $index = 0 ; |
|
||||
my $colors = $graph->get('dclrs'); |
|
||||
my $color ; |
|
||||
foreach $color (@new_colors) { |
|
||||
if ($valid_colour_name{$color} ) { |
|
||||
# warn "Pushed $color ." ; |
|
||||
$colors->[$index] = $color ; |
|
||||
$index ++ ; |
|
||||
} else { |
|
||||
warn "Invalid color $color requested." ; |
|
||||
} |
|
||||
} |
|
||||
# warn "Setting dclrs." ; |
|
||||
$graph->set( dclrs => $colors) ; |
|
||||
# warn "Set dclrs." ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my %opt = ('transparent' => 0, |
|
||||
'x_label_position' => 0.5, |
|
||||
'show_values' => 1, |
|
||||
'y_max_value' => 100, |
|
||||
'overwrite' => 0); |
|
||||
if ($title) {$opt{'title'} = $title;} |
|
||||
if ($xlabel) {$opt{'x_label'} = $xlabel;} |
|
||||
if ($ylabel) {$opt{'y_label'} = $ylabel;} |
|
||||
if ($ymax) {$opt{'y_max_value'} = $ymax;} |
|
||||
if ($ymin) {$opt{'y_min_value'} = $ymin;} |
|
||||
if ($t_margin) {$opt{'t_margin'} = $t_margin;} |
|
||||
if ($b_margin) {$opt{'b_margin'} = $b_margin;} |
|
||||
if ($l_margin) {$opt{'l_margin'} = $l_margin;} |
|
||||
if ($r_margin) {$opt{'r_margin'} = $r_margin;} |
|
||||
if ($yticknum) {$opt{'y_tick_number'} = $yticknum;} |
|
||||
if ($bar_spacing) {$opt{'bar_spacing'} = $bar_spacing;} |
|
||||
if ($bargroup_spacing) {$opt{'bargroup_spacing'} = $bargroup_spacing;} |
|
||||
if ($show_values) {$opt{'show_values'} = $show_values;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position;} |
|
||||
if ($transparent) {$opt{'transparent'} = $transparent;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite;} |
|
||||
if ($interlaced) {$opt{'interlaced'} = $interlaced;} |
|
||||
if ($bgclr) {$opt{'bgclr'} = $bgclr;} |
|
||||
if ($fgclr) {$opt{'fgclr'} = $fgclr;} |
|
||||
if ($boxclr) {$opt{'boxclr'} = $boxclr;} |
|
||||
if ($accentclr) {$opt{'accentclr'} = $accentclr;} |
|
||||
if ($shadowclr) {$opt{'shadowclr'} = $shadowclr;} |
|
||||
if ($shadow_depth) {$opt{'shadow_depth'} = $shadow_depth;} |
|
||||
if ($labelclr) {$opt{'labelclr'} = $labelclr ;} |
|
||||
if ($axislabelclr) {$opt{'axislabelclr'} = $axislabelclr ;} |
|
||||
if ($legendclr) {$opt{'legendclr'} = $legendclr ;} |
|
||||
if ($valuesclr) {$opt{'valuesclr'} = $valuesclr ;} |
|
||||
if ($textclr) {$opt{'textclr'} = $textclr ;} |
|
||||
if ($dclrs) {$opt{'dclrs'} = $dclrs ;} |
|
||||
if ($borderclrs) {$opt{'borderclrs'} = $borderclrs ;} |
|
||||
if ($cycle_clrs) {$opt{'cycle_clrs'} = $cycle_clrs ;} |
|
||||
if ($accent_treshold) {$opt{'accent_treshold'} = $accent_treshold ;} |
|
||||
if ($long_ticks) {$opt{'long_ticks'} = $long_ticks ;} |
|
||||
if ($tick_length) {$opt{'tick_length'} = $tick_length ;} |
|
||||
if ($x_ticks) {$opt{'x_ticks'} = $x_ticks ;} |
|
||||
if ($y_number_format) {$opt{'y_number_format'} = $y_number_format ;} |
|
||||
if ($x_label_skip) {$opt{'x_label_skip'} = $x_label_skip ;} |
|
||||
if ($y_label_skip) {$opt{'y_label_skip'} = $y_label_skip ;} |
|
||||
if ($x_last_label_skip) {$opt{'x_last_label_skip'} = $x_last_label_skip ;} |
|
||||
if ($x_tick_offset) {$opt{'x_tick_offset'} = $x_tick_offset ;} |
|
||||
if ($x_all_ticks) {$opt{'x_all_ticks'} = $x_all_ticks ;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position ;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position ;} |
|
||||
if ($x_labels_vertical) {$opt{'x_labels_vertical'} = $x_labels_vertical ;} |
|
||||
if ($x_plot_values) {$opt{'x_plot_values'} = $x_plot_values ;} |
|
||||
if ($y_plot_values) {$opt{'y_plot_values'} = $y_plot_values ;} |
|
||||
if ($box_axis) {$opt{'box_axis'} = $box_axis ;} |
|
||||
if ($no_axes) {$opt{'no_axes'} = $no_axes ;} |
|
||||
if ($two_axes) {$opt{'two_axes'} = $two_axes ;} |
|
||||
if ($use_axis) {$opt{'use_axis'} = $use_axis ;} |
|
||||
if ($zero_axis) {$opt{'zero_axis'} = $zero_axis ;} |
|
||||
if ($zero_axis_only) {$opt{'zero_axis_only'} = $zero_axis_only ;} |
|
||||
if ($axis_space) {$opt{'axis_space'} = $axis_space ;} |
|
||||
if ($text_space) {$opt{'text_space'} = $text_space ;} |
|
||||
if ($cumulate) {$opt{'cumulate'} = $cumulate ;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite ;} |
|
||||
if ($correct_width) {$opt{'correct_width'} = $correct_width ;} |
|
||||
if ($values_vertical) {$opt{'values_vertical'} = $values_vertical ;} |
|
||||
if ($values_space) {$opt{'values_space'} = $values_space ;} |
|
||||
if ($values_format) {$opt{'values_format'} = $values_format ;} |
|
||||
if ($legend_placement) {$opt{'legend_placement'} = $legend_placement ;} |
|
||||
if ($legend_marker_width) {$opt{'legend_marker_width'} = $legend_marker_width ;} |
|
||||
if ($legend_marker_height) {$opt{'legend_marker_height'} = $legend_marker_height ;} |
|
||||
if ($lg_cols) {$opt{'lg_cols'} = $lg_cols ;} |
|
||||
|
|
||||
if ((defined $Legend) && (ref($Legend) eq "ARRAY") && ($#{${Legend}} >= 0)) { |
|
||||
$graph -> set_legend(@{$Legend}) ; |
|
||||
} else { |
|
||||
warn "ERROR: Empty Legend array passed to XXX." ; |
|
||||
} |
|
||||
|
|
||||
$graph->set(%opt) or die $graph->error; |
|
||||
$graph->set_title_font(gdGiantFont); |
|
||||
$graph->set_x_label_font(gdGiantFont); |
|
||||
$graph->set_y_label_font(gdGiantFont); |
|
||||
$graph->set_x_axis_font(gdGiantFont); |
|
||||
$graph->set_y_axis_font(gdGiantFont); |
|
||||
$graph->set_values_font(gdGiantFont); |
|
||||
$graph->set_legend_font(gdGiantFont); |
|
||||
|
|
||||
my $gd = $graph->plot($Data_In) ; |
|
||||
|
|
||||
return $gd |
|
||||
|
|
||||
} |
|
||||
|
|
||||
1 ; |
|
||||
|
|
||||
@ -1,464 +0,0 @@ |
|||||
#!/usr/bin/perl -w |
|
||||
# |
|
||||
# $Id: bargraph_multi.pm |
|
||||
# |
|
||||
|
|
||||
use strict; |
|
||||
use diagnostics ; |
|
||||
package bargraph_multi ; |
|
||||
use Exporter () ; |
|
||||
@bargraph_multi::ISA = qw(Exporter) ; |
|
||||
@bargraph_multi::EXPORT = qw(Build_Labeled_X_Axis_Graph_Str Build_Labeled_X_Axis_Graph_Obj |
|
||||
Build_Labeled_X_Axis_Graph_Obj_opts Build_Labeled_X_Axis_Graph_Str_opts ) ; |
|
||||
@bargraph_multi::EXPORT_OK = qw( ) ; |
|
||||
use GD; |
|
||||
use GD::Graph::colour; |
|
||||
use GD::Graph::bars; |
|
||||
use GD::Graph::hbars; |
|
||||
use GD::Graph::bars3d; |
|
||||
#use Data::Dumper; |
|
||||
|
|
||||
|
|
||||
|
|
||||
# This perl code is builds Graphs using the GD::Graph modules. |
|
||||
# This code deals with a non-numeric X-Axis. Each tick on the X-Axis is the name of a group. |
|
||||
# The other style has a numeric X-Axis. |
|
||||
sub Build_Labeled_X_Axis_Graph_Str { |
|
||||
# The parameters are: |
|
||||
# $Data_In - A reference to a list of lists. (aka, Array of Arrays) |
|
||||
# Each of the sublists has the same number of elements. |
|
||||
# An element might be the undef value. |
|
||||
# The first sublist is the names of the groups. |
|
||||
# The other sublists are related to the elements in the $Legend parameter. |
|
||||
# $Legend - A reference to a list. |
|
||||
# Each element of the list is the name of a group. |
|
||||
# The data for each group is a sublist in the $Data_In parameter. |
|
||||
# ---- The rest of the parameters are individual options as scalars: numbers, character strings, or undef. |
|
||||
# The returned value is a list of (reference to the plotted graphical object, and graphic string in the mode. |
|
||||
my ($Data_In, $Legend, $Graphic_Mode, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols |
|
||||
) = @_ ; |
|
||||
my $Graph_Obj ; |
|
||||
$Graph_Obj = &Build_Labeled_X_Axis_Graph_Obj |
|
||||
($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ; |
|
||||
my $Plotted_Str ; |
|
||||
unless (defined $Graph_Obj) { |
|
||||
return (undef, "") ; |
|
||||
} else { |
|
||||
if ($Graphic_Mode =~ m/png/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> png ; |
|
||||
} elsif ($Graphic_Mode =~ m/gif/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> gif ; |
|
||||
} else { |
|
||||
return ($Graphic_Mode, "Unsupported Graphical Mode $Graph_Obj.\n") ; |
|
||||
} |
|
||||
} |
|
||||
return ($Graph_Obj, $Plotted_Str) ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub Build_Labeled_X_Axis_Graph_Obj { |
|
||||
my ($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, |
|
||||
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, |
|
||||
$colorscheme, $bar_spacing, $bargroup_spacing, |
|
||||
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite, |
|
||||
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth, |
|
||||
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs, |
|
||||
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format, |
|
||||
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks, |
|
||||
$x_labels_vertical, $x_plot_values, $y_plot_values, |
|
||||
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space, |
|
||||
$text_space, $cumulate, $correct_width, $values_vertical, $values_space, |
|
||||
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) = @_ ; |
|
||||
# $colorscheme is a colon seperated string of colors. |
|
||||
my $HBI_Debug_Obj = 0 ; |
|
||||
my $Data_In_sublist ; my $Data_In_cnt = 0 ; |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
warn "INFO: " . __FILE__ . " Parm List Legend array len is $#{$Legend}.\n" ; |
|
||||
foreach $Data_In_sublist (@{$Data_In}) { |
|
||||
warn "INFO: Data array len is $#{$Data_In_sublist}.\n" ; |
|
||||
$Data_In_cnt ++ ; |
|
||||
} |
|
||||
warn "INFO: Data array $Data_In_cnt elements.\n" ; |
|
||||
} |
|
||||
|
|
||||
my $graph; |
|
||||
if ($hbar) { |
|
||||
#print STDERR "hbar set\n"; |
|
||||
$graph = GD::Graph::hbars->new($xdim,$ydim); |
|
||||
} else { |
|
||||
$graph = GD::Graph::bars->new($xdim,$ydim); |
|
||||
#print STDERR "hbar not set\n"; |
|
||||
} |
|
||||
my @ret_colour_names_avail = () ; |
|
||||
my %valid_colour_name = () ; |
|
||||
@ret_colour_names_avail = GD::Graph::colour::colour_list(59) ; |
|
||||
for my $clr_name (@ret_colour_names_avail) { |
|
||||
if (defined $clr_name) {$valid_colour_name{$clr_name} = 1;} |
|
||||
} |
|
||||
|
|
||||
# The keys of the hash array valid_colour_name are the known color names. |
|
||||
|
|
||||
# warn $full_colour_list ; |
|
||||
# warn "The number of colours is $#ret_colour_names_avail ." ; |
|
||||
# The colors I found at one time are: pink lbrown lred purple |
|
||||
# dblue lpurple green white gold blue dyellow red lgreen marine |
|
||||
# dred cyan yellow lblue orange lgray dgreen dbrown lyellow |
|
||||
# black gray dpink dgray lorange dpurple |
|
||||
|
|
||||
# Set blue yellow if the colorscheme parameter is 1. |
|
||||
# else use the default. |
|
||||
if ($colorscheme and $colorscheme ==1) { |
|
||||
$graph->set( dclrs => [ qw(blue yellow) ] ); |
|
||||
} elsif ($colorscheme) { |
|
||||
my @new_colors = split /:/ , $colorscheme ; |
|
||||
my $index = 0 ; |
|
||||
my $colors = $graph->get('dclrs'); |
|
||||
my $color ; |
|
||||
foreach $color (@new_colors) { |
|
||||
if ($valid_colour_name{$color} ) { |
|
||||
# warn "Pushed $color ." ; |
|
||||
$colors->[$index] = $color ; |
|
||||
$index ++ ; |
|
||||
} else { |
|
||||
warn "Invalid color $color requested." ; |
|
||||
} |
|
||||
} |
|
||||
# warn "Setting dclrs." ; |
|
||||
$graph->set( dclrs => $colors) ; |
|
||||
# warn "Set dclrs." ; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my %opt = ('transparent' => 0, |
|
||||
'x_label_position' => 0.5, |
|
||||
'show_values' => 1, |
|
||||
'y_max_value' => 100, |
|
||||
'overwrite' => 0); |
|
||||
if ($title) {$opt{'title'} = $title;} |
|
||||
if ($xlabel) {$opt{'x_label'} = $xlabel;} |
|
||||
if ($ylabel) {$opt{'y_label'} = $ylabel;} |
|
||||
if ($ymax) {$opt{'y_max_value'} = $ymax;} |
|
||||
if ($ymin) {$opt{'y_min_value'} = $ymin;} |
|
||||
if ($t_margin) {$opt{'t_margin'} = $t_margin;} |
|
||||
if ($b_margin) {$opt{'b_margin'} = $b_margin;} |
|
||||
if ($l_margin) {$opt{'l_margin'} = $l_margin;} |
|
||||
if ($r_margin) {$opt{'r_margin'} = $r_margin;} |
|
||||
if ($yticknum) {$opt{'y_tick_number'} = $yticknum;} |
|
||||
if ($bar_spacing) {$opt{'bar_spacing'} = $bar_spacing;} |
|
||||
if ($bargroup_spacing) {$opt{'bargroup_spacing'} = $bargroup_spacing;} |
|
||||
if ($show_values) {$opt{'show_values'} = $show_values;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position;} |
|
||||
if ($transparent) {$opt{'transparent'} = $transparent;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite;} |
|
||||
if ($interlaced) {$opt{'interlaced'} = $interlaced;} |
|
||||
if ($bgclr) {$opt{'bgclr'} = $bgclr;} |
|
||||
if ($fgclr) {$opt{'fgclr'} = $fgclr;} |
|
||||
if ($boxclr) {$opt{'boxclr'} = $boxclr;} |
|
||||
if ($accentclr) {$opt{'accentclr'} = $accentclr;} |
|
||||
if ($shadowclr) {$opt{'shadowclr'} = $shadowclr;} |
|
||||
if ($shadow_depth) {$opt{'shadow_depth'} = $shadow_depth;} |
|
||||
if ($labelclr) {$opt{'labelclr'} = $labelclr ;} |
|
||||
if ($axislabelclr) {$opt{'axislabelclr'} = $axislabelclr ;} |
|
||||
if ($legendclr) {$opt{'legendclr'} = $legendclr ;} |
|
||||
if ($valuesclr) {$opt{'valuesclr'} = $valuesclr ;} |
|
||||
if ($textclr) {$opt{'textclr'} = $textclr ;} |
|
||||
if ($dclrs) {$opt{'dclrs'} = $dclrs ;} |
|
||||
if ($borderclrs) {$opt{'borderclrs'} = $borderclrs ;} |
|
||||
if ($cycle_clrs) {$opt{'cycle_clrs'} = $cycle_clrs ;} |
|
||||
if ($accent_treshold) {$opt{'accent_treshold'} = $accent_treshold ;} |
|
||||
if ($long_ticks) {$opt{'long_ticks'} = $long_ticks ;} |
|
||||
if ($tick_length) {$opt{'tick_length'} = $tick_length ;} |
|
||||
if ($x_ticks) {$opt{'x_ticks'} = $x_ticks ;} |
|
||||
if ($y_number_format) {$opt{'y_number_format'} = $y_number_format ;} |
|
||||
if ($x_label_skip) {$opt{'x_label_skip'} = $x_label_skip ;} |
|
||||
if ($y_label_skip) {$opt{'y_label_skip'} = $y_label_skip ;} |
|
||||
if ($x_last_label_skip) {$opt{'x_last_label_skip'} = $x_last_label_skip ;} |
|
||||
if ($x_tick_offset) {$opt{'x_tick_offset'} = $x_tick_offset ;} |
|
||||
if ($x_all_ticks) {$opt{'x_all_ticks'} = $x_all_ticks ;} |
|
||||
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position ;} |
|
||||
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position ;} |
|
||||
if ($x_labels_vertical) {$opt{'x_labels_vertical'} = $x_labels_vertical ;} |
|
||||
if ($x_plot_values) {$opt{'x_plot_values'} = $x_plot_values ;} |
|
||||
if ($y_plot_values) {$opt{'y_plot_values'} = $y_plot_values ;} |
|
||||
if ($box_axis) {$opt{'box_axis'} = $box_axis ;} |
|
||||
if ($no_axes) {$opt{'no_axes'} = $no_axes ;} |
|
||||
if ($two_axes) {$opt{'two_axes'} = $two_axes ;} |
|
||||
if ($use_axis) {$opt{'use_axis'} = $use_axis ;} |
|
||||
if ($zero_axis) {$opt{'zero_axis'} = $zero_axis ;} |
|
||||
if ($zero_axis_only) {$opt{'zero_axis_only'} = $zero_axis_only ;} |
|
||||
if ($axis_space) {$opt{'axis_space'} = $axis_space ;} |
|
||||
if ($text_space) {$opt{'text_space'} = $text_space ;} |
|
||||
if ($cumulate) {$opt{'cumulate'} = $cumulate ;} |
|
||||
if ($overwrite) {$opt{'overwrite'} = $overwrite ;} |
|
||||
if ($correct_width) {$opt{'correct_width'} = $correct_width ;} |
|
||||
if ($values_vertical) {$opt{'values_vertical'} = $values_vertical ;} |
|
||||
if ($values_space) {$opt{'values_space'} = $values_space ;} |
|
||||
if ($values_format) {$opt{'values_format'} = $values_format ;} |
|
||||
if ($legend_placement) {$opt{'legend_placement'} = $legend_placement ;} |
|
||||
if ($legend_marker_width) {$opt{'legend_marker_width'} = $legend_marker_width ;} |
|
||||
if ($legend_marker_height) {$opt{'legend_marker_height'} = $legend_marker_height ;} |
|
||||
if ($lg_cols) {$opt{'lg_cols'} = $lg_cols ;} |
|
||||
|
|
||||
if ((defined $Legend) && (ref($Legend) eq "ARRAY") && ($#{${Legend}} >= 0)) { |
|
||||
$graph -> set_legend(@{$Legend}) ; |
|
||||
} else { |
|
||||
warn "ERROR: Empty Legend array passed to XXX." ; |
|
||||
} |
|
||||
|
|
||||
$graph->set(%opt) or die $graph->error; |
|
||||
$graph->set_title_font(gdGiantFont); |
|
||||
$graph->set_x_label_font(gdGiantFont); |
|
||||
$graph->set_y_label_font(gdGiantFont); |
|
||||
$graph->set_x_axis_font(gdGiantFont); |
|
||||
$graph->set_y_axis_font(gdGiantFont); |
|
||||
$graph->set_values_font(gdGiantFont); |
|
||||
$graph->set_legend_font(gdGiantFont); |
|
||||
|
|
||||
my $gd = $graph->plot($Data_In) ; |
|
||||
|
|
||||
return $gd |
|
||||
|
|
||||
} |
|
||||
|
|
||||
# This perl code is builds Graphs using the GD::Graph modules. |
|
||||
# This code deals with a non-numeric X-Axis. Each tick on the X-Axis is the name of a group. |
|
||||
# The other style has a numeric X-Axis. |
|
||||
sub Build_Labeled_X_Axis_Graph_Str_opts { |
|
||||
# The parameters are: |
|
||||
# $Data_In - A reference to a list of lists. (aka, Array of Arrays) |
|
||||
# Each of the sublists has the same number of elements. |
|
||||
# An element might be the undef value. |
|
||||
# The first sublist is the names of the groups. |
|
||||
# The other sublists are related to the elements in the $Legend parameter. |
|
||||
# $Legend - A reference to a list. |
|
||||
# $opts - A reference to a hash array of parameters. |
|
||||
# We use the standard options for the GRAPH package. |
|
||||
# We add Graphic_Mode for PNG or GIF. |
|
||||
# We add the fonts to use for text. The default font is a large font. |
|
||||
# The returned value is a list of (reference to the plotted graphical object, and graphic string in the mode. |
|
||||
my ($Data_In, $Legend, $opts) = @_ ; |
|
||||
my $Graph_Obj ; |
|
||||
$Graph_Obj = &Build_Labeled_X_Axis_Graph_Obj_opts ($Data_In, $Legend, $opts) ; |
|
||||
my $Graphic_Mode = $opts->{'Graphic_Mode'} ; |
|
||||
unless (defined $Graphic_Mode) {$Graphic_Mode = "png" ;} |
|
||||
my $Graphic_Mode_ref = ref $Graphic_Mode ; |
|
||||
if ($Graphic_Mode_ref) { |
|
||||
return ($Graph_Obj, "Unsupported Reference Graphical Mode $Graphic_Mode_ref.\n") ; |
|
||||
} |
|
||||
my $Plotted_Str ; |
|
||||
unless (defined $Graph_Obj) { |
|
||||
return (undef, "") ; |
|
||||
} else { |
|
||||
if ($Graphic_Mode =~ m/png/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> png ; |
|
||||
} elsif ($Graphic_Mode =~ m/gif/i) { |
|
||||
$Plotted_Str = $Graph_Obj -> gif ; |
|
||||
} else { |
|
||||
return ($Graph_Obj, "Unsupported Graphical Mode $Graphic_Mode.\n") ; |
|
||||
} |
|
||||
} |
|
||||
return ($Graph_Obj, $Plotted_Str) ; |
|
||||
} |
|
||||
|
|
||||
sub Build_Labeled_X_Axis_Graph_Obj_opts { |
|
||||
my ($Data_In, $Legend, $opts ) = @_ ; |
|
||||
# $colorscheme is a colon seperated string of colors. |
|
||||
my $HBI_Debug_Obj = 0 ; |
|
||||
my $Data_In_sublist ; my $Data_In_cnt = 0 ; |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
warn "INFO: " . __FILE__ . " Opts Legend array len is $#{$Legend}.\n" ; |
|
||||
foreach $Data_In_sublist (@{$Data_In}) { |
|
||||
warn "INFO: Data array len is $#{$Data_In_sublist}.\n" ; |
|
||||
warn "Info: Elements " . join(" ", @{$Data_In_sublist}) . " X" ; |
|
||||
$Data_In_cnt ++ ; |
|
||||
} |
|
||||
warn "INFO: Data array $Data_In_cnt elements.\n" ; |
|
||||
if (defined $Data_In) { |
|
||||
my $Data_In_ref = ref $Data_In ; |
|
||||
if ($Data_In_ref) { |
|
||||
warn "INFO: Data_In is a reference to a $Data_In_ref \n" ; |
|
||||
} else { |
|
||||
warn "INFO: Data_In is a scalar $Data_In \n" ; |
|
||||
} |
|
||||
} else { |
|
||||
warn "ERROR: Data_In is not defined." ; |
|
||||
} |
|
||||
} |
|
||||
my $hbar = $opts->{'hbar'} ; |
|
||||
my $xdim = $opts->{'width'} ; |
|
||||
my $ydim = $opts->{'height'} ; |
|
||||
warn "INFO: hbar $hbar xdim $xdim ydim $ydim X" if ($HBI_Debug_Obj) ; |
|
||||
my $graph; |
|
||||
if ($hbar) { |
|
||||
#print STDERR "hbar set\n"; |
|
||||
$graph = GD::Graph::hbars->new($xdim,$ydim); |
|
||||
} else { |
|
||||
$graph = GD::Graph::bars->new($xdim,$ydim); |
|
||||
#print STDERR "hbar not set\n"; |
|
||||
} |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
if (defined $graph) { |
|
||||
my $graph_ref = ref $graph ; |
|
||||
if ($graph_ref) { |
|
||||
warn "INFO: graph is a reference to a $graph_ref \n" ; |
|
||||
} else { |
|
||||
warn "INFO: graph is a scalar $graph \n" ; |
|
||||
} |
|
||||
} else { |
|
||||
warn "ERROR: graph is not defined." ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
my @ret_colour_names_avail = () ; |
|
||||
my %valid_colour_name = () ; |
|
||||
@ret_colour_names_avail = GD::Graph::colour::colour_list(59) ; |
|
||||
for my $clr_name (@ret_colour_names_avail) { |
|
||||
if (defined $clr_name) {$valid_colour_name{$clr_name} = 1;} |
|
||||
} |
|
||||
|
|
||||
# The keys of the hash array valid_colour_name are the known color names. |
|
||||
|
|
||||
# warn $full_colour_list ; |
|
||||
# warn "The number of colours is $#ret_colour_names_avail ." ; |
|
||||
# The colors I found at one time are: pink lbrown lred purple |
|
||||
# dblue lpurple green white gold blue dyellow red lgreen marine |
|
||||
# dred cyan yellow lblue orange lgray dgreen dbrown lyellow |
|
||||
# black gray dpink dgray lorange dpurple |
|
||||
|
|
||||
# Set blue yellow if the colorscheme parameter is 1. |
|
||||
# else use the default. |
|
||||
my $colorscheme = $opts->{'colorscheme'} ; |
|
||||
if ((defined $colorscheme) and ($colorscheme eq 1)) { |
|
||||
$graph->set( dclrs => [ qw(blue yellow) ] ); |
|
||||
} elsif ($colorscheme) { |
|
||||
my @new_colors = split /:/ , $colorscheme ; |
|
||||
my $index = 0 ; |
|
||||
my $colors = $graph->get('dclrs'); |
|
||||
my $color ; |
|
||||
foreach $color (@new_colors) { |
|
||||
if ($valid_colour_name{$color} ) { |
|
||||
# warn "Pushed $color ." ; |
|
||||
$colors->[$index] = $color ; |
|
||||
$index ++ ; |
|
||||
} else { |
|
||||
warn "Invalid color $color requested." ; |
|
||||
} |
|
||||
} |
|
||||
# warn "Setting dclrs." ; |
|
||||
$graph->set( dclrs => $colors) ; |
|
||||
# warn "Set dclrs." ; |
|
||||
} |
|
||||
|
|
||||
if ((defined $Legend) && (ref($Legend) eq "ARRAY") && ($#{${Legend}} >= 0)) { |
|
||||
$graph -> set_legend(@{$Legend}) ; |
|
||||
} else { |
|
||||
warn "ERROR: Empty Legend array passed to XXX." ; |
|
||||
} |
|
||||
|
|
||||
my %G_Opts = () ; |
|
||||
my $key ; |
|
||||
foreach $key (keys %{$opts}) { |
|
||||
$G_Opts{$key} = $opts->{$key} ; |
|
||||
} |
|
||||
delete $G_Opts{'colorscheme'} ; |
|
||||
delete $G_Opts{'hbar'} ; |
|
||||
delete $G_Opts{'Graphic_Mode'} ; |
|
||||
delete $G_Opts{'width'} ; |
|
||||
delete $G_Opts{'height'} ; |
|
||||
|
|
||||
unless ($graph->set(%G_Opts)) { |
|
||||
warn "ERROR: graph->set complained" ; |
|
||||
warn $graph->error; |
|
||||
} |
|
||||
my $use_font ; |
|
||||
$use_font = $opts->{'title_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_title_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_title_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'x_label_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_x_label_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_x_label_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'y_label_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_y_label_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_y_label_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'x_axis_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_x_axis_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_x_axis_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'y_axis_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_y_axis_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_y_axis_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'values_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_values_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_values_font(gdGiantFont); |
|
||||
} |
|
||||
$use_font = $opts->{'legend_font'} ; |
|
||||
if (defined $use_font) { |
|
||||
$graph->set_legend_font($use_font); |
|
||||
} else { |
|
||||
$graph->set_legend_font(gdGiantFont); |
|
||||
} |
|
||||
|
|
||||
# my $gd = $graph->plot(@{$Data_In}) ; # rejected. Bad Data |
|
||||
my $gd = $graph->plot($Data_In) ; |
|
||||
|
|
||||
if ($HBI_Debug_Obj) { |
|
||||
if (defined $gd) { |
|
||||
my $gd_ref = ref $gd ; |
|
||||
if ($gd_ref) { |
|
||||
warn "INFO: gd is a reference to a $gd_ref \n" ; |
|
||||
} else { |
|
||||
warn "INFO: gd is a scalar $gd \n" ; |
|
||||
} |
|
||||
} else { |
|
||||
warn "ERROR: gd is not defined." ; |
|
||||
warn "ERROR: graph error is " . $graph->error ; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return $gd |
|
||||
} |
|
||||
|
|
||||
1 ; |
|
||||
|
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,547 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: creportsf.pl,v 1.11 2006/10/19 17:35:29 psims Exp $ |
|
||||
# |
|
||||
# Source File: creportsf.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'qlib.pl'; |
|
||||
|
|
||||
$FORM{'frm'}=""; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
# ACT-C-004&Test Statistics by Test User Filter |
|
||||
### DED 10/24/2002 Added Filter-by-Question functionality |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
|
|
||||
$REPORT{'rptid'}=""; |
|
||||
@rptdefs = &get_data("reports.$SESSION{'clid'}"); |
|
||||
@lbls = split(/&/, $rptdefs[0]); |
|
||||
foreach $rptdef (@rptdefs) { |
|
||||
chomp ($rptdef); |
|
||||
@flds = split(/&/, $rptdef); |
|
||||
if ($flds[0] eq $FORM{'rptno'}) { |
|
||||
for $i (0 .. $#lbls) { |
|
||||
$REPORT{$lbls[$i]} = $flds[$i]; |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
$REPORT{'rptid'}=$FORM{'rptno'}; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
&print_report_header(); |
|
||||
if ($FORM{'filterbyques'} eq "on") { |
|
||||
&print_question_filter(); |
|
||||
} |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
&print_report_C_004(); |
|
||||
} |
|
||||
&print_report_footer(); |
|
||||
} |
|
||||
|
|
||||
sub print_report_header() { |
|
||||
my $i; |
|
||||
# C_004 |
|
||||
$FORM{'rptdesc'} =~ s/\+/ /g; |
|
||||
$faction="$cgiroot/teststats.pl"; |
|
||||
$ftarget="rptwindow"; |
|
||||
$fparms="<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"export\" value=\"$FORM{'export'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"testsummary\" value=\"$FORM{'testsummary'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"showobs\" value=\"$FORM{'showobs'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"showcmts\" value=\"$FORM{'showcmts'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"statsbysubj\" value=\"$FORM{'statsbysubj'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndnme\" value=\"$FORM{'cndnme'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndeml\" value=\"$FORM{'cndeml'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndscr\" value=\"$FORM{'cndscr'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd1\" value=\"$FORM{'cnd1'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd2\" value=\"$FORM{'cnd2'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd3\" value=\"$FORM{'cnd3'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd4\" value=\"$FORM{'cnd4'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"moto\" value=\"$FORM{'moto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"dyto\" value=\"$FORM{'dyto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"yrto\" value=\"$FORM{'yrto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"mofm\" value=\"$FORM{'mofm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"dyfm\" value=\"$FORM{'dyfm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"yrfm\" value=\"$FORM{'yrfm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"specfilter\" value=\"$FORM{'specfilter'}\">\n"); |
|
||||
$fjscript=" |
|
||||
function onWdwLoad() { |
|
||||
var oform=document.rptform1; |
|
||||
} |
|
||||
window.onload=onWdwLoad; |
|
||||
"; |
|
||||
if ($FORM{'filterbyques'} eq "on") { |
|
||||
$fuserjscript=" |
|
||||
function rptform1_submit(oform) { |
|
||||
var ans=\"\"; |
|
||||
if (oform.question.selectedIndex == 0) { |
|
||||
alert(\"You must select at least one question by which to filter!\"); |
|
||||
return false; |
|
||||
} |
|
||||
if (oform.selanswer.selectedIndex == -1) { |
|
||||
alert(\"You must select at least one answer by which to filter!\"); |
|
||||
return false; |
|
||||
} |
|
||||
for (var i = 0; i < oform.selanswer.options.length; i++) { |
|
||||
if (oform.selanswer.options[i].selected) |
|
||||
if (oform.selanswer.options[i].text == \"No Response\") { |
|
||||
ans=\"\&\"+oform.selanswer.options[i].text; |
|
||||
} else { |
|
||||
ans=ans+\"\&\"+i; |
|
||||
} |
|
||||
} |
|
||||
oform.answer.value=ans; |
|
||||
} |
|
||||
"; |
|
||||
} else { |
|
||||
$fuserjscript=" |
|
||||
function rptform1_submit(oform) { |
|
||||
return true; |
|
||||
} |
|
||||
"; |
|
||||
} |
|
||||
print "<HTML> |
|
||||
<HEAD> |
|
||||
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
$fjscript |
|
||||
$fuserjscript |
|
||||
function right(e) { |
|
||||
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} else { |
|
||||
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
//document.onmousedown=right; |
|
||||
//document.onmouseup=right; |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEDOWN); |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEUP); |
|
||||
//window.onmousedown=right; |
|
||||
//window.onmouseup=right; |
|
||||
// --> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
"; |
|
||||
print "<FORM name=\"rptform1\" action=\"$faction\" METHOD=POST target=\"$ftarget\" onSubmit=\"return rptform1_submit(this)\">\n"; |
|
||||
print "$fparms\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%> |
|
||||
<TR> |
|
||||
<TD VALIGN=\"top\">$CLIENT{'logo'}</TD> |
|
||||
<TD> </TD> |
|
||||
<TD ALIGN=\"right\"> |
|
||||
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\"> |
|
||||
<B>$FORM{'rptdesc'}<BR>$FORM{'rptid'}</B><BR>\ \;<BR> |
|
||||
</FONT> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
print "<CENTER>\n"; |
|
||||
print "<B>$TEST{'desc'} ($TEST{'id'})</B><BR>\n"; |
|
||||
print "<B>$xlatphrase[745]</B><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub print_report_footer() { |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%> |
|
||||
<TR>"; |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=button name=exclude_sr value=\"$xlatphrase[742]\" onClick=\"self_reg_onClick(this.form,'sr')\"> |
|
||||
</TD>\n"; |
|
||||
} |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=submit value=\"$xlatphrase[2]\"> |
|
||||
</TD>\n"; |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=button name=exclude_nonsr value=\"$xlatphrase[743]\" onClick=\"self_reg_onClick(this.form,'non')\"> |
|
||||
</TD>"; |
|
||||
} |
|
||||
print " |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
print "</FORM>\n"; |
|
||||
print "</BODY>\n</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub print_question_filter() { |
|
||||
&build_question_select_list(); |
|
||||
&build_question_answer_list(); |
|
||||
$fuserjscript=" |
|
||||
function show_question(question) { |
|
||||
var jqid=\"$quesid\", jqtxt=\"$questxt\", jqans=\"$quesans\"; |
|
||||
ajqid=jqid.split(\"\&\"); |
|
||||
ajtxt=jqtxt.split(\"\&\"); |
|
||||
ajans=jqans.split(\"\&\"); |
|
||||
for (var i = 0; i < ajqid.length; i++) { |
|
||||
if (ajqid[i] == question.value) { |
|
||||
document.rptform1.questxt.value=ajtxt[i]; |
|
||||
ajqans=ajans[i].split(\"\;\"); |
|
||||
lajqans=ajqans.length; |
|
||||
//document.rptform1.questxt.value=lajqans+\":\"+ajqans[lajqans]+\":\"; |
|
||||
for (var j = 0; j < lajqans; j++) { |
|
||||
document.rptform1.selanswer.options[j].text=ajqans[j]; |
|
||||
} |
|
||||
document.rptform1.selanswer.options[lajqans].text=\"No Response\"; |
|
||||
for (var j = lajqans+1; j < document.rptform1.selanswer.length; j++) { |
|
||||
document.rptform1.selanswer.options[j].text=\"\"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
"; |
|
||||
print "<SCRIPT language=\"JavaScript\">$fuserjscript</SCRIPT>\n"; |
|
||||
print "<HR><B>Filter By Question</B><p>\n"; |
|
||||
print "<TABLE><TR>\n"; |
|
||||
print "<td align=center><B><u>Question</u></B></td>\n"; |
|
||||
print "<td align=center><B><u>Answer</u></B></td>\n"; |
|
||||
print "</TR>\n"; |
|
||||
print "<TR>\n"; |
|
||||
print "<td align=center valign=top><SELECT name=question onChange=show_question(this)><OPTION>$TEST{'questionlist'}</SELECT>\n"; |
|
||||
#print "</td>\n"; |
|
||||
#print "<td align=center>\n"; |
|
||||
print "<p><textarea name=questxt cols=50></textarea>\n"; |
|
||||
print "</td>\n"; |
|
||||
print "<td align=center>\n"; |
|
||||
print "<input type=hidden name=answer value=\"\">\n"; |
|
||||
print "<SELECT name=selanswer MULTIPLE>\n"; |
|
||||
for (0 .. $numans+1) { |
|
||||
print "<OPTION>\n"; |
|
||||
} |
|
||||
print "</SELECT></td>\n"; |
|
||||
print "</td>\n"; |
|
||||
print "</TR></TABLE>\n"; |
|
||||
} |
|
||||
sub print_report_C_004 { |
|
||||
my @filelist = &get_test_result_files($testcomplete, "$CLIENT{'clid'}","$TEST{'id'}"); |
|
||||
my @converter; |
|
||||
if ($SESSION{'uid'} ne '') { |
|
||||
my $imaregistrar = &get_a_key("cnd.$CLIENT{'clid'}", $SESSION{'uid'}, "registrar"); |
|
||||
if ($imaregistrar eq 'Y') { |
|
||||
foreach $rotator (@filelist) { |
|
||||
my @cnd = split(/\./, $rotator); |
|
||||
my $creator = &get_a_key("cnd.$CLIENT{'clid'}", $cnd[1], "createdby"); |
|
||||
push(@converter, $rotator) unless $creator ne $SESSION{'uid'}; |
|
||||
} |
|
||||
@filelist = @converter; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::logerr("No SESSION{uid} set!"); |
|
||||
} |
|
||||
my @colhdrs=(); |
|
||||
push @colhdrs,"right:$xlatphrase[744]"; |
|
||||
push @colhdrs,"left:$xlatphrase[745]"; |
|
||||
push @colhdrs,"left:$xlatphrase[746]"; |
|
||||
push @colhdrs,"left:$xlatphrase[747]"; |
|
||||
push @colhdrs,"left:$xlatphrase[748]"; |
|
||||
push @colhdrs,"center:$xlatphrase[749]"; |
|
||||
push @colhdrs,"center:$xlatphrase[137]"; |
|
||||
push @colhdrs,"center:$xlatphrase[692]"; |
|
||||
push @colhdrs,"right:$xlatphrase[361]"; |
|
||||
my @dataflds=(); |
|
||||
my @unsorted=(); |
|
||||
my $row=""; |
|
||||
my @qsumry=(); |
|
||||
my $user=""; |
|
||||
my $joint="\&"; |
|
||||
my $colhdr; |
|
||||
my $colalgn; |
|
||||
if ($FORM{'mofm'} < 10) { $FORM{'mofm'}="0$FORM{'mofm'}";} |
|
||||
if ($FORM{'moto'} < 10) { $FORM{'moto'}="0$FORM{'moto'}";} |
|
||||
if ($FORM{'dyfm'} < 10) { $FORM{'dyfm'}="0$FORM{'dyfm'}";} |
|
||||
if ($FORM{'dyto'} < 10) { $FORM{'dyto'}="0$FORM{'dyto'}";} |
|
||||
my $datefm="$FORM{'yrfm'}\-$FORM{'mofm'}\-$FORM{'dyfm'}"; |
|
||||
my $dateto="$FORM{'yrto'}\-$FORM{'moto'}\-$FORM{'dyto'}"; |
|
||||
|
|
||||
for ($fidx = 0; $fidx <= $#filelist; $fidx++ ) { |
|
||||
$user = $filelist[$fidx]; |
|
||||
$user =~ s/.$TEST{'id'}//g; |
|
||||
$user =~ s/$CLIENT{'clid'}.//g; |
|
||||
my $history = get_testhistory_from_log($CLIENT{'clid'},$user,$FORM{'tstid'}); |
|
||||
if (not defined $history) { |
|
||||
$history = get_cnd_test_from_history($testcomplete,$CLIENT{'clid'},$user,$FORM{'tstid'}); |
|
||||
} else { |
|
||||
#print STDERR "$user from log.\n"; |
|
||||
} |
|
||||
if (not defined $history) { |
|
||||
# no log file entry for this test |
|
||||
#print STDERR "$user inferred from $testcomplete.$pathsep.$filelist[$fidx]\n"; |
|
||||
my $mtime = (stat($testcomplete.$pathsep.$filelist[$fidx]))[9]; |
|
||||
$history->{'end'} = $mtime; |
|
||||
$history->{'start'} = $history->{'end'}; |
|
||||
} |
|
||||
$completedat = &format_date_time("yyyy-mm-dd", "1", "-10000", $history->{'end'}); |
|
||||
$displaydate = &format_date_time("dd-mmm-yyyy", "1", "-10000", $history->{'end'}); |
|
||||
if (&date_out_of_range($completedat,$datefm,$dateto)) { |
|
||||
next; |
|
||||
} |
|
||||
|
|
||||
&get_test_sequence_for_reports( $CLIENT{'clid'}, $user, $TEST{'id'}); |
|
||||
@qsumry = split(/\&/, $SUBTEST_SUMMARY{2}); |
|
||||
&get_candidate_profile($CLIENT{'clid'},$user); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nml'}"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nmf'}"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nmm'}"); |
|
||||
$row=join($joint,$row,"$user"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'selfreg'}"); |
|
||||
$row=join('&',$row,$qsumry[0],$qsumry[1],$qsumry[2]); |
|
||||
push @unsorted, $row; |
|
||||
$row=""; |
|
||||
} |
|
||||
my @sorted=sort @unsorted; |
|
||||
@unsorted=(); |
|
||||
my $rowcount=$#filelist+1; |
|
||||
print "<HR><B>Filter By User</B><p>\n"; |
|
||||
&print_report_dataextract_header($rowcount,@colhdrs); |
|
||||
$jsarray = ""; |
|
||||
for $i (0 .. $#sorted) { |
|
||||
@dataflds=split($joint, $sorted[$i]); |
|
||||
print "<TR>\n"; |
|
||||
for $i (0 .. $#dataflds) { |
|
||||
($colalgn,$colhdr) = split(/:/,$colhdrs[$i]); |
|
||||
if ($i == 0) { |
|
||||
print "\t\t<td align=$colalgn valign=top><input type=checkbox name=\"inc$dataflds[4]\" value=\"$dataflds[4]\">"; |
|
||||
} else { |
|
||||
if ($colhdr eq "Self-Reg") { |
|
||||
print "\t\t<td align=$colalgn valign=top>$dataflds[$i]\n"; |
|
||||
print "\t\t<input type=hidden name=sr$dataflds[4] value=$dataflds[5]></td>\n"; |
|
||||
$jsarray .= "$dataflds[4]:"; |
|
||||
} else { |
|
||||
print "\t\t<td align=$colalgn valign=top>$dataflds[$i]</td>\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "<TR>\n"; |
|
||||
} |
|
||||
$jsarray = substr($jsarray,0,-1); |
|
||||
print "</TABLE>\n"; |
|
||||
$jscript=" |
|
||||
function self_reg_onClick(oform,exc) { |
|
||||
var jsl=\"$jsarray\", jsa, n, s; |
|
||||
jsa=jsl.split(':'); |
|
||||
for (var i=0; i<jsa.length;i++) { |
|
||||
n=\"oform.\"+\"sr\"+jsa[i]+\".value\"; |
|
||||
s=eval(\"oform.\"+\"inc\"+jsa[i]); |
|
||||
if (eval(n) == \"Y\") { |
|
||||
if (exc == \"sr\") { |
|
||||
s.checked=true; |
|
||||
} else { |
|
||||
s.checked=false; |
|
||||
} |
|
||||
} else { |
|
||||
if (exc == \"sr\") { |
|
||||
s.checked=false; |
|
||||
} else { |
|
||||
s.checked=true; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
"; |
|
||||
print "<SCRIPT language=\"JavaScript\">$jscript</SCRIPT>\n"; |
|
||||
@sorted=(); |
|
||||
} |
|
||||
|
|
||||
sub print_report_dataextract_header { |
|
||||
my ($ncount,@cols)= @_; |
|
||||
my $colhdr; |
|
||||
my $colalgn; |
|
||||
my $i; |
|
||||
print "<TABLE cellpadding=2 cellspacing=2 border=0 width=\"100\%\">\n"; |
|
||||
print "\t<TR>\n"; |
|
||||
for $i (0 .. $#cols) { |
|
||||
($colalgn,$colhdr) = split(/:/,$cols[$i]); |
|
||||
print "\t\t<td align=$colalgn valign=top><b><u>$colhdr</u></b></td>\n"; |
|
||||
} |
|
||||
print "\t</TR>\n"; |
|
||||
} |
|
||||
|
|
||||
# |
|
||||
# |
|
||||
# |
|
||||
sub get_test_sequence_for_reports { |
|
||||
&get_test_profile($_[0], $_[2]); |
|
||||
$trash3 = join($pathsep, $testcomplete, "$_[0].$_[1].$_[2]"); |
|
||||
$msg = ""; |
|
||||
if ( ! open(TESTFILE,"<$trash3") ) { |
|
||||
&logger::logerr("Unable to open $trash3: $!"); |
|
||||
$msg="failed"; |
|
||||
print "<!-- open failure\n$trash3\n$!\n-->\n"; |
|
||||
$msg = ""; |
|
||||
} else { |
|
||||
@seqlines = <TESTFILE>; |
|
||||
close TESTFILE; |
|
||||
$isubtest = 1; $iidx = 0; $iaryidx = 1; |
|
||||
foreach $seqline (@seqlines) { |
|
||||
chop ($seqline); |
|
||||
if ($iidx eq 0) { |
|
||||
@status = split(/&/, $seqline); |
|
||||
$ifld = 0; |
|
||||
$TEST_SESSION{'clid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'uid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'tstid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'state'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'dscl'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'profb'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'id'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'profa'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'srvy'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'ntfy'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'emlcnd'} = $status[$ifld++]; |
|
||||
@status = (); |
|
||||
$iidx++; |
|
||||
} else { |
|
||||
if ($iaryidx eq 1) { |
|
||||
$SUBTEST_QUESTIONS{$isubtest} = $seqline; |
|
||||
} elsif ($iaryidx eq 2) { |
|
||||
$SUBTEST_ANSWERS{$isubtest} = $seqline; |
|
||||
} elsif ($iaryidx eq 3) { |
|
||||
$seqline =~ s/\%0D\%0A/<br>/g; |
|
||||
$SUBTEST_RESPONSES{$isubtest} = unmunge($seqline); |
|
||||
} elsif ($iaryidx eq 4) { |
|
||||
$SUBTEST_SUMMARY{$isubtest} = $seqline; |
|
||||
} |
|
||||
$iaryidx++; |
|
||||
if ($iaryidx eq 5) { |
|
||||
$iaryidx = 1; |
|
||||
$isubtest++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
@seqlines = (); |
|
||||
return; |
|
||||
} |
|
||||
|
|
||||
#wac merge v - this code commented out because replaced the calls with EFL changes |
|
||||
# |
|
||||
# $patterncount = CountFiles($directory, $pattern1, $pattern2); |
|
||||
# |
|
||||
#sub CountFiles { |
|
||||
# opendir (GDIR, $_[0]); |
|
||||
# @cdots = readdir(GDIR); |
|
||||
# closedir GDIR; |
|
||||
# $ncount=0; |
|
||||
# $crmmask1 = "$_[1]"; |
|
||||
# $crmmask2 = "$_[2]"; |
|
||||
# foreach $crmfile (@cdots) { |
|
||||
# if (($crmfile =~ /$crmmask1/ ) && ($crmfile =~ /$crmmask2/ )) {$ncount++;} |
|
||||
# } |
|
||||
# @cdots = (); |
|
||||
# return $ncount; |
|
||||
#} |
|
||||
# wac merge ^ |
|
||||
|
|
||||
################################################################################ |
|
||||
# |
|
||||
# Subroutine Name |
|
||||
# GetTestHeader |
|
||||
# |
|
||||
# Description |
|
||||
# This subroutine returns the header of the test file |
|
||||
# |
|
||||
# Inputs |
|
||||
# $clientId -- The id of the client to search through |
|
||||
# |
|
||||
# Outputs |
|
||||
# None |
|
||||
# |
|
||||
# Returns |
|
||||
# @testFields -- An array of fields in the header |
|
||||
# |
|
||||
#adt080401############################################################################### |
|
||||
sub GetTestHeader |
|
||||
{ |
|
||||
my $clientId = $_[0]; |
|
||||
my @testList = &get_data("tests.$clientId"); |
|
||||
my $testHdr = $testList[0]; |
|
||||
my $testFields; |
|
||||
|
|
||||
chop( $testHdr ); |
|
||||
@testFields = split( /&/, $testHdr ); |
|
||||
|
|
||||
return @testFields; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
#adt080401############################################################################### |
|
||||
# |
|
||||
# Subroutine Name |
|
||||
# GetTestsByOwner |
|
||||
# |
|
||||
# Description |
|
||||
# This subroutine searches through the test definition file of the given |
|
||||
# client for all the tests that are owned by the given user id or are public |
|
||||
# |
|
||||
# Inputs |
|
||||
# $clientId -- The id of the client to search through |
|
||||
# $ownedBy -- The name of the owner of the test to search for |
|
||||
# |
|
||||
# Outputs |
|
||||
# None |
|
||||
# |
|
||||
# Returns |
|
||||
# @tests -- An array of tests owned by the given user id |
|
||||
# |
|
||||
################################################################################ |
|
||||
sub GetTestsByOwner |
|
||||
{ |
|
||||
my $clientId = $_[0]; |
|
||||
my $ownedBy = $_[1]; |
|
||||
my %currHash; |
|
||||
my @testList = &get_data("tests.$clientId"); |
|
||||
my @currField; |
|
||||
my @tests; |
|
||||
my $testHdr = $testList[0]; |
|
||||
my $testFields; |
|
||||
my $testCntr; |
|
||||
|
|
||||
@testFields = &GetTestHeader( $clientId ); |
|
||||
|
|
||||
for( $testCntr = 1; $testCntr < $#testList; $testCntr++ ) |
|
||||
{ |
|
||||
#print "<b>$testList[$testCntr]</b><br>\n"; |
|
||||
chop( $testList[$testCntr] ); |
|
||||
@currField = split( '&', $testList[$testCntr] ); |
|
||||
for( 0 .. $#testFields ) |
|
||||
{ |
|
||||
$currHash{$testFields[$_]} = $currField[$_]; |
|
||||
} |
|
||||
|
|
||||
#print "$currHash{'ownedby'} - $ownedBy<p>"; |
|
||||
if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) ) |
|
||||
{ |
|
||||
push( @tests, $testList[$testCntr] ); |
|
||||
#print "<font color=\"#ff0000\"><b>$testList[$testCntr]</b></font><br>\n"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return @tests; |
|
||||
} |
|
||||
|
|
||||
@ -1,555 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: creportsf.pl,v 1.11 2006/10/19 17:35:29 psims Exp $ |
|
||||
# |
|
||||
# Source File: creportsf.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
require 'qlib.pl'; |
|
||||
|
|
||||
$FORM{'frm'}=""; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
# ACT-C-004&Test Statistics by Test User Filter |
|
||||
### DED 10/24/2002 Added Filter-by-Question functionality |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
|
|
||||
$REPORT{'rptid'}=""; |
|
||||
@rptdefs = &get_data("reports.$SESSION{'clid'}"); |
|
||||
@lbls = split(/&/, $rptdefs[0]); |
|
||||
foreach $rptdef (@rptdefs) { |
|
||||
chomp ($rptdef); |
|
||||
@flds = split(/&/, $rptdef); |
|
||||
if ($flds[0] eq $FORM{'rptno'}) { |
|
||||
for $i (0 .. $#lbls) { |
|
||||
$REPORT{$lbls[$i]} = $flds[$i]; |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
$REPORT{'rptid'}=$FORM{'rptno'}; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); |
|
||||
&print_report_header(); |
|
||||
if ($FORM{'filterbyques'} eq "on") { |
|
||||
&print_question_filter(); |
|
||||
} |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
&print_report_C_004(); |
|
||||
} |
|
||||
&print_report_footer(); |
|
||||
} |
|
||||
|
|
||||
sub print_report_header() { |
|
||||
my $i; |
|
||||
# C_004 |
|
||||
$FORM{'rptdesc'} =~ s/\+/ /g; |
|
||||
$faction="$cgiroot/teststats.pl"; |
|
||||
$ftarget="rptwindow"; |
|
||||
$fparms="<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"export\" value=\"$FORM{'export'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"tstid\" value=\"$FORM{'tstid'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"testsummary\" value=\"$FORM{'testsummary'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"showobs\" value=\"$FORM{'showobs'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"showcmts\" value=\"$FORM{'showcmts'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"anoncmts\" value=\"$FORM{'anoncmts'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"statsbysubj\" value=\"$FORM{'statsbysubj'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndnme\" value=\"$FORM{'cndnme'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndeml\" value=\"$FORM{'cndeml'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cndscr\" value=\"$FORM{'cndscr'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd1\" value=\"$FORM{'cnd1'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd2\" value=\"$FORM{'cnd2'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd3\" value=\"$FORM{'cnd3'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"cnd4\" value=\"$FORM{'cnd4'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"moto\" value=\"$FORM{'moto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"dyto\" value=\"$FORM{'dyto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"yrto\" value=\"$FORM{'yrto'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"mofm\" value=\"$FORM{'mofm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"dyfm\" value=\"$FORM{'dyfm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"yrfm\" value=\"$FORM{'yrfm'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"specfilter\" value=\"$FORM{'specfilter'}\">\n"); |
|
||||
$fjscript=" |
|
||||
function onWdwLoad() { |
|
||||
var oform=document.rptform1; |
|
||||
} |
|
||||
window.onload=onWdwLoad; |
|
||||
"; |
|
||||
if ($FORM{'filterbyques'} eq "on") { |
|
||||
$fuserjscript=" |
|
||||
function rptform1_submit(oform) { |
|
||||
var ans=\"\"; |
|
||||
if (oform.question.selectedIndex == 0) { |
|
||||
alert(\"You must select at least one question by which to filter!\"); |
|
||||
return false; |
|
||||
} |
|
||||
if (oform.selanswer.selectedIndex == -1) { |
|
||||
alert(\"You must select at least one answer by which to filter!\"); |
|
||||
return false; |
|
||||
} |
|
||||
for (var i = 0; i < oform.selanswer.options.length; i++) { |
|
||||
if (oform.selanswer.options[i].selected) |
|
||||
if (oform.selanswer.options[i].text == \"No Response\") { |
|
||||
ans=\"\&\"+oform.selanswer.options[i].text; |
|
||||
} else { |
|
||||
ans=ans+\"\&\"+i; |
|
||||
} |
|
||||
} |
|
||||
oform.answer.value=ans; |
|
||||
} |
|
||||
"; |
|
||||
} else { |
|
||||
$fuserjscript=" |
|
||||
function rptform1_submit(oform) { |
|
||||
return true; |
|
||||
} |
|
||||
"; |
|
||||
} |
|
||||
print "<HTML> |
|
||||
<HEAD> |
|
||||
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
$fjscript |
|
||||
$fuserjscript |
|
||||
function right(e) { |
|
||||
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} else { |
|
||||
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
//document.onmousedown=right; |
|
||||
//document.onmouseup=right; |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEDOWN); |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEUP); |
|
||||
//window.onmousedown=right; |
|
||||
//window.onmouseup=right; |
|
||||
// --> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
"; |
|
||||
print "<FORM name=\"rptform1\" action=\"$faction\" METHOD=POST target=\"$ftarget\" onSubmit=\"return rptform1_submit(this)\">\n"; |
|
||||
print "$fparms\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%> |
|
||||
<TR> |
|
||||
<TD VALIGN=\"top\">$CLIENT{'logo'}</TD> |
|
||||
<TD> </TD> |
|
||||
<TD ALIGN=\"right\"> |
|
||||
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\"> |
|
||||
<B>$FORM{'rptdesc'}<BR>$FORM{'rptid'}</B><BR>\ \;<BR> |
|
||||
</FONT> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
print "<CENTER>\n"; |
|
||||
print "<B>$TEST{'desc'} ($TEST{'id'})</B><BR>\n"; |
|
||||
print "<B>$xlatphrase[745]</B><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub print_report_footer() { |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%> |
|
||||
<TR>"; |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=button name=exclude_sr value=\"$xlatphrase[742]\" onClick=\"self_reg_onClick(this.form,'sr')\"> |
|
||||
</TD>\n"; |
|
||||
} |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=submit value=\"$xlatphrase[2]\"> |
|
||||
</TD>\n"; |
|
||||
if ($FORM{'specfilter'} eq "on") { |
|
||||
print " |
|
||||
<TD ALIGN=\"center\"> |
|
||||
<input type=button name=exclude_nonsr value=\"$xlatphrase[743]\" onClick=\"self_reg_onClick(this.form,'non')\"> |
|
||||
</TD>"; |
|
||||
} |
|
||||
print " |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
print "</FORM>\n"; |
|
||||
print "</BODY>\n</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub print_question_filter() { |
|
||||
&build_question_select_list(); |
|
||||
&build_question_answer_list(); |
|
||||
$fuserjscript=" |
|
||||
function show_question(question) { |
|
||||
var jqid=\"$quesid\", jqtxt=\"$questxt\", jqans=\"$quesans\"; |
|
||||
ajqid=jqid.split(\"\&\"); |
|
||||
ajtxt=jqtxt.split(\"\&\"); |
|
||||
ajans=jqans.split(\"\&\"); |
|
||||
for (var i = 0; i < ajqid.length; i++) { |
|
||||
if (ajqid[i] == question.value) { |
|
||||
document.rptform1.questxt.value=ajtxt[i]; |
|
||||
ajqans=ajans[i].split(\"\;\"); |
|
||||
lajqans=ajqans.length; |
|
||||
//document.rptform1.questxt.value=lajqans+\":\"+ajqans[lajqans]+\":\"; |
|
||||
for (var j = 0; j < lajqans; j++) { |
|
||||
document.rptform1.selanswer.options[j].text=ajqans[j]; |
|
||||
} |
|
||||
document.rptform1.selanswer.options[lajqans].text=\"No Response\"; |
|
||||
for (var j = lajqans+1; j < document.rptform1.selanswer.length; j++) { |
|
||||
document.rptform1.selanswer.options[j].text=\"\"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
"; |
|
||||
print "<SCRIPT language=\"JavaScript\">$fuserjscript</SCRIPT>\n"; |
|
||||
print "<HR><B>Filter By Question</B><p>\n"; |
|
||||
print "<TABLE><TR>\n"; |
|
||||
print "<td align=center><B><u>Question</u></B></td>\n"; |
|
||||
print "<td align=center><B><u>Answer</u></B></td>\n"; |
|
||||
print "</TR>\n"; |
|
||||
print "<TR>\n"; |
|
||||
print "<td align=center valign=top><SELECT name=question onChange=show_question(this)><OPTION>$TEST{'questionlist'}</SELECT>\n"; |
|
||||
#print "</td>\n"; |
|
||||
#print "<td align=center>\n"; |
|
||||
print "<p><textarea name=questxt cols=50></textarea>\n"; |
|
||||
print "</td>\n"; |
|
||||
print "<td align=center>\n"; |
|
||||
print "<input type=hidden name=answer value=\"\">\n"; |
|
||||
print "<SELECT name=selanswer MULTIPLE>\n"; |
|
||||
for (0 .. $numans+1) { |
|
||||
print "<OPTION>\n"; |
|
||||
} |
|
||||
print "</SELECT></td>\n"; |
|
||||
print "</td>\n"; |
|
||||
print "</TR></TABLE>\n"; |
|
||||
} |
|
||||
sub print_report_C_004 { |
|
||||
my @filelist = &get_test_result_files($testcomplete, "$CLIENT{'clid'}","$TEST{'id'}"); |
|
||||
my @converter; |
|
||||
if ($SESSION{'uid'} ne '') { |
|
||||
my $imaregistrar = &get_a_key("cnd.$CLIENT{'clid'}", $SESSION{'uid'}, "registrar"); |
|
||||
if ($imaregistrar eq 'Y') { |
|
||||
foreach $rotator (@filelist) { |
|
||||
my @cnd = split(/\./, $rotator); |
|
||||
my $creator = &get_a_key("cnd.$CLIENT{'clid'}", $cnd[1], "createdby"); |
|
||||
push(@converter, $rotator) unless $creator ne $SESSION{'uid'}; |
|
||||
} |
|
||||
@filelist = @converter; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::logerr("No SESSION{uid} set!"); |
|
||||
} |
|
||||
my @colhdrs=(); |
|
||||
push @colhdrs,"right:$xlatphrase[744]"; |
|
||||
push @colhdrs,"left:$xlatphrase[745]"; |
|
||||
push @colhdrs,"left:$xlatphrase[746]"; |
|
||||
push @colhdrs,"left:$xlatphrase[747]"; |
|
||||
push @colhdrs,"left:$xlatphrase[748]"; |
|
||||
push @colhdrs,"center:$xlatphrase[749]"; |
|
||||
push @colhdrs,"center:$xlatphrase[137]"; |
|
||||
push @colhdrs,"center:$xlatphrase[692]"; |
|
||||
push @colhdrs,"right:$xlatphrase[361]"; |
|
||||
my @dataflds=(); |
|
||||
my @unsorted=(); |
|
||||
my $row=""; |
|
||||
my @qsumry=(); |
|
||||
my $user=""; |
|
||||
my $joint="\&"; |
|
||||
my $colhdr; |
|
||||
my $colalgn; |
|
||||
if ($FORM{'mofm'} < 10) { $FORM{'mofm'}="0$FORM{'mofm'}";} |
|
||||
if ($FORM{'moto'} < 10) { $FORM{'moto'}="0$FORM{'moto'}";} |
|
||||
if ($FORM{'dyfm'} < 10) { $FORM{'dyfm'}="0$FORM{'dyfm'}";} |
|
||||
if ($FORM{'dyto'} < 10) { $FORM{'dyto'}="0$FORM{'dyto'}";} |
|
||||
my $datefm="$FORM{'yrfm'}\-$FORM{'mofm'}\-$FORM{'dyfm'}"; |
|
||||
my $dateto="$FORM{'yrto'}\-$FORM{'moto'}\-$FORM{'dyto'}"; |
|
||||
|
|
||||
for ($fidx = 0; $fidx <= $#filelist; $fidx++ ) { |
|
||||
$user = $filelist[$fidx]; |
|
||||
$user =~ s/.$TEST{'id'}//g; |
|
||||
$user =~ s/$CLIENT{'clid'}.//g; |
|
||||
my $history = get_testhistory_from_log($CLIENT{'clid'},$user,$FORM{'tstid'}); |
|
||||
if (not defined $history) { |
|
||||
$history = get_cnd_test_from_history($testcomplete,$CLIENT{'clid'},$user,$FORM{'tstid'}); |
|
||||
} else { |
|
||||
#print STDERR "$user from log.\n"; |
|
||||
} |
|
||||
if (not defined $history) { |
|
||||
# no log file entry for this test |
|
||||
#print STDERR "$user inferred from $testcomplete.$pathsep.$filelist[$fidx]\n"; |
|
||||
my $mtime = (stat($testcomplete.$pathsep.$filelist[$fidx]))[9]; |
|
||||
$history->{'end'} = $mtime; |
|
||||
$history->{'start'} = $history->{'end'}; |
|
||||
} |
|
||||
$completedat = &format_date_time("yyyy-mm-dd", "1", "-10000", $history->{'end'}); |
|
||||
$displaydate = &format_date_time("dd-mmm-yyyy", "1", "-10000", $history->{'end'}); |
|
||||
if (&date_out_of_range($completedat,$datefm,$dateto)) { |
|
||||
next; |
|
||||
} |
|
||||
|
|
||||
&get_test_sequence_for_reports( $CLIENT{'clid'}, $user, $TEST{'id'}); |
|
||||
@qsumry = split(/\&/, $SUBTEST_SUMMARY{2}); |
|
||||
&get_candidate_profile($CLIENT{'clid'},$user); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nml'}"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nmf'}"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'nmm'}"); |
|
||||
$row=join($joint,$row,"$user"); |
|
||||
$row=join($joint,$row,"$CANDIDATE{'selfreg'}"); |
|
||||
$row=join('&',$row,$qsumry[0],$qsumry[1],$qsumry[2]); |
|
||||
push @unsorted, $row; |
|
||||
$row=""; |
|
||||
} |
|
||||
my @sorted=sort @unsorted; |
|
||||
@unsorted=(); |
|
||||
my $rowcount=$#filelist+1; |
|
||||
print "<HR><B>Filter By User</B><p>\n"; |
|
||||
&print_report_dataextract_header($rowcount,@colhdrs); |
|
||||
$jsarray = ""; |
|
||||
for $i (0 .. $#sorted) { |
|
||||
@dataflds=split($joint, $sorted[$i]); |
|
||||
print "<TR>\n"; |
|
||||
for $i (0 .. $#dataflds) { |
|
||||
($colalgn,$colhdr) = split(/:/,$colhdrs[$i]); |
|
||||
if ($i == 0) { |
|
||||
print "\t\t<td align=$colalgn valign=top><input type=checkbox name=\"inc$dataflds[4]\" value=\"$dataflds[4]\">"; |
|
||||
} else { |
|
||||
if ($colhdr eq "Self-Reg") { |
|
||||
print "\t\t<td align=$colalgn valign=top>$dataflds[$i]\n"; |
|
||||
print "\t\t<input type=hidden name=sr$dataflds[4] value=$dataflds[5]></td>\n"; |
|
||||
$jsarray .= "$dataflds[4]:"; |
|
||||
} else { |
|
||||
print "\t\t<td align=$colalgn valign=top>$dataflds[$i]</td>\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
print "<TR>\n"; |
|
||||
} |
|
||||
$jsarray = substr($jsarray,0,-1); |
|
||||
print "</TABLE>\n"; |
|
||||
$jscript=" |
|
||||
function self_reg_onClick(oform,exc) { |
|
||||
var jsl=\"$jsarray\", jsa, n, s; |
|
||||
jsa=jsl.split(':'); |
|
||||
for (var i=0; i<jsa.length;i++) { |
|
||||
n=\"oform.\"+\"sr\"+jsa[i]+\".value\"; |
|
||||
s=eval(\"oform.\"+\"inc\"+jsa[i]); |
|
||||
if (eval(n) == \"Y\") { |
|
||||
if (exc == \"sr\") { |
|
||||
s.checked=true; |
|
||||
} else { |
|
||||
s.checked=false; |
|
||||
} |
|
||||
} else { |
|
||||
if (exc == \"sr\") { |
|
||||
s.checked=false; |
|
||||
} else { |
|
||||
s.checked=true; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
"; |
|
||||
print "<SCRIPT language=\"JavaScript\">$jscript</SCRIPT>\n"; |
|
||||
@sorted=(); |
|
||||
} |
|
||||
|
|
||||
sub print_report_dataextract_header { |
|
||||
my ($ncount,@cols)= @_; |
|
||||
my $colhdr; |
|
||||
my $colalgn; |
|
||||
my $i; |
|
||||
print "<TABLE cellpadding=2 cellspacing=2 border=0 width=\"100\%\">\n"; |
|
||||
print "\t<TR>\n"; |
|
||||
for $i (0 .. $#cols) { |
|
||||
($colalgn,$colhdr) = split(/:/,$cols[$i]); |
|
||||
print "\t\t<td align=$colalgn valign=top><b><u>$colhdr</u></b></td>\n"; |
|
||||
} |
|
||||
print "\t</TR>\n"; |
|
||||
} |
|
||||
|
|
||||
# |
|
||||
# |
|
||||
# |
|
||||
sub get_test_sequence_for_reports { |
|
||||
# There is a duplicate, and better version of this function in testlib.pl. |
|
||||
&get_test_profile($_[0], $_[2]); |
|
||||
$trash3 = join($pathsep, $testcomplete, "$_[0].$_[1].$_[2]"); |
|
||||
$msg = ""; |
|
||||
if ( ! open(TESTFILE,"<$trash3") ) { |
|
||||
&logger::logerr("Unable to open $trash3: $!"); |
|
||||
$msg="failed"; |
|
||||
print "<!-- open failure\n$trash3\n$!\n-->\n"; |
|
||||
$msg = ""; |
|
||||
# Clear the hashs. Otherwise the calling code will process the current contents. |
|
||||
%TEST_SESSION = () ; |
|
||||
%SUBTEST_QUESTIONS = () ; |
|
||||
%SUBTEST_ANSWERS = () ; |
|
||||
%SUBTEST_RESPONSES = () ; |
|
||||
%SUBTEST_SUMMARY = () ; |
|
||||
} else { |
|
||||
@seqlines = <TESTFILE>; |
|
||||
close TESTFILE; |
|
||||
$isubtest = 1; $iidx = 0; $iaryidx = 1; |
|
||||
foreach $seqline (@seqlines) { |
|
||||
chop ($seqline); |
|
||||
if ($iidx eq 0) { |
|
||||
@status = split(/&/, $seqline); |
|
||||
$ifld = 0; |
|
||||
$TEST_SESSION{'clid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'uid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'tstid'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'state'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'dscl'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'profb'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'id'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'profa'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'srvy'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'ntfy'} = $status[$ifld++]; |
|
||||
$TEST_SESSION{'emlcnd'} = $status[$ifld++]; |
|
||||
@status = (); |
|
||||
$iidx++; |
|
||||
} else { |
|
||||
if ($iaryidx eq 1) { |
|
||||
$SUBTEST_QUESTIONS{$isubtest} = $seqline; |
|
||||
} elsif ($iaryidx eq 2) { |
|
||||
$SUBTEST_ANSWERS{$isubtest} = $seqline; |
|
||||
} elsif ($iaryidx eq 3) { |
|
||||
$seqline =~ s/\%0D\%0A/<br>/g; |
|
||||
$SUBTEST_RESPONSES{$isubtest} = unmunge($seqline); |
|
||||
} elsif ($iaryidx eq 4) { |
|
||||
$SUBTEST_SUMMARY{$isubtest} = $seqline; |
|
||||
} |
|
||||
$iaryidx++; |
|
||||
if ($iaryidx eq 5) { |
|
||||
$iaryidx = 1; |
|
||||
$isubtest++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
@seqlines = (); |
|
||||
return; |
|
||||
} |
|
||||
|
|
||||
#wac merge v - this code commented out because replaced the calls with EFL changes |
|
||||
# |
|
||||
# $patterncount = CountFiles($directory, $pattern1, $pattern2); |
|
||||
# |
|
||||
#sub CountFiles { |
|
||||
# opendir (GDIR, $_[0]); |
|
||||
# @cdots = readdir(GDIR); |
|
||||
# closedir GDIR; |
|
||||
# $ncount=0; |
|
||||
# $crmmask1 = "$_[1]"; |
|
||||
# $crmmask2 = "$_[2]"; |
|
||||
# foreach $crmfile (@cdots) { |
|
||||
# if (($crmfile =~ /$crmmask1/ ) && ($crmfile =~ /$crmmask2/ )) {$ncount++;} |
|
||||
# } |
|
||||
# @cdots = (); |
|
||||
# return $ncount; |
|
||||
#} |
|
||||
# wac merge ^ |
|
||||
|
|
||||
################################################################################ |
|
||||
# |
|
||||
# Subroutine Name |
|
||||
# GetTestHeader |
|
||||
# |
|
||||
# Description |
|
||||
# This subroutine returns the header of the test file |
|
||||
# |
|
||||
# Inputs |
|
||||
# $clientId -- The id of the client to search through |
|
||||
# |
|
||||
# Outputs |
|
||||
# None |
|
||||
# |
|
||||
# Returns |
|
||||
# @testFields -- An array of fields in the header |
|
||||
# |
|
||||
#adt080401############################################################################### |
|
||||
sub GetTestHeader |
|
||||
{ |
|
||||
my $clientId = $_[0]; |
|
||||
my @testList = &get_data("tests.$clientId"); |
|
||||
my $testHdr = $testList[0]; |
|
||||
my $testFields; |
|
||||
|
|
||||
chop( $testHdr ); |
|
||||
@testFields = split( /&/, $testHdr ); |
|
||||
|
|
||||
return @testFields; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
#adt080401############################################################################### |
|
||||
# |
|
||||
# Subroutine Name |
|
||||
# GetTestsByOwner |
|
||||
# |
|
||||
# Description |
|
||||
# This subroutine searches through the test definition file of the given |
|
||||
# client for all the tests that are owned by the given user id or are public |
|
||||
# |
|
||||
# Inputs |
|
||||
# $clientId -- The id of the client to search through |
|
||||
# $ownedBy -- The name of the owner of the test to search for |
|
||||
# |
|
||||
# Outputs |
|
||||
# None |
|
||||
# |
|
||||
# Returns |
|
||||
# @tests -- An array of tests owned by the given user id |
|
||||
# |
|
||||
################################################################################ |
|
||||
sub GetTestsByOwner |
|
||||
{ |
|
||||
my $clientId = $_[0]; |
|
||||
my $ownedBy = $_[1]; |
|
||||
my %currHash; |
|
||||
my @testList = &get_data("tests.$clientId"); |
|
||||
my @currField; |
|
||||
my @tests; |
|
||||
my $testHdr = $testList[0]; |
|
||||
my $testFields; |
|
||||
my $testCntr; |
|
||||
|
|
||||
@testFields = &GetTestHeader( $clientId ); |
|
||||
|
|
||||
for( $testCntr = 1; $testCntr < $#testList; $testCntr++ ) |
|
||||
{ |
|
||||
#print "<b>$testList[$testCntr]</b><br>\n"; |
|
||||
chop( $testList[$testCntr] ); |
|
||||
@currField = split( '&', $testList[$testCntr] ); |
|
||||
for( 0 .. $#testFields ) |
|
||||
{ |
|
||||
$currHash{$testFields[$_]} = $currField[$_]; |
|
||||
} |
|
||||
|
|
||||
#print "$currHash{'ownedby'} - $ownedBy<p>"; |
|
||||
if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) ) |
|
||||
{ |
|
||||
push( @tests, $testList[$testCntr] ); |
|
||||
#print "<font color=\"#ff0000\"><b>$testList[$testCntr]</b></font><br>\n"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return @tests; |
|
||||
} |
|
||||
|
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,52 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: forgot.pl,v 1.2 2006/01/23 21:39:30 ddoughty Exp $ |
|
||||
# |
|
||||
# Source File: forgot.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&traceoutput("login.pl"); # TRACE IF ACTIVE |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
$SESSION{'clid'} = $FORM{'clid'}; |
|
||||
$SESSION{'lang'} = $FORM{'lang'}; |
|
||||
&get_client_configuration(); |
|
||||
&traceoutput("login.pl:$FORM{'clid'}:$FORM{'uid'}:$FORM{'pwd'}"); # TRACE IF ACTIVE |
|
||||
&setbrowsertype(); |
|
||||
|
|
||||
# Load Index.html |
|
||||
if ($FORM{'home'} eq 'client') { |
|
||||
|
|
||||
if ($FORM{'uid'} eq '') { |
|
||||
return 0; |
|
||||
} else { |
|
||||
my $tmpfile = "cnd.$FORM{'clid'}"; |
|
||||
my @cnds = &get_data($tmpfile); |
|
||||
foreach my $cnd (@cnds) { |
|
||||
chop ($cnd); |
|
||||
my @flds = split(/&/, $cnd); |
|
||||
if ($flds[0] eq $FORM{'uid'}) { |
|
||||
my $pw = $flds[1]; |
|
||||
my $email = $flds[11]; |
|
||||
$mmsubj = "Password for ".$CLIENT{'clnmc'}; |
|
||||
$mmbody = "Dear $flds[3],\n"; |
|
||||
$mmbody .= " Your password for the "; |
|
||||
$mmbody .= $CLIENT{'clnmc'}; |
|
||||
$mmbody .= " Test Manager system is: $pw.\n"; |
|
||||
&send_mail($mmautonotifyfrom, $email, $mmsubj, $mmbody); |
|
||||
} |
|
||||
} |
|
||||
@lines = &get_template("cindex"); |
|
||||
} |
|
||||
} else { |
|
||||
@lines = &get_template("shome"); |
|
||||
} |
|
||||
foreach $line (@lines) { |
|
||||
$line = &xlatline($line); |
|
||||
} |
|
||||
@ -1,20 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: imagepop.pl,v 1.3 2006/01/23 21:39:30 ddoughty Exp $ |
|
||||
# |
|
||||
# Source File: image.pl |
|
||||
|
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
print "<HTML> |
|
||||
<BODY> |
|
||||
<IMG SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$FORM{'img'}\" BORDER=0> |
|
||||
</BODY> |
|
||||
</HTML>\n"; |
|
||||
} |
|
||||
@ -1,18 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# Source File: likert_rep_wall_104.pl |
|
||||
# $Header$ |
|
||||
|
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD></HEAD>\n"; |
|
||||
print "<FRAMESET frameborder=0 rows=\"60,*\">\n"; |
|
||||
print "\t<FRAME noresize scrolling=\"no\" name=\"rptindx003\" frameborder=0 src=\"$urlroot/likert_wall_A_104.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=1&rptno=$FORM{'rptno'}\">\n"; |
|
||||
print "\t<FRAMESET frameborder=0 cols=\"230,*\">\n"; |
|
||||
print "\t\t<FRAME name=\"rpttidx003\" frameborder=0 src=\"$urlroot/likert_wall_A_104.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\">\n"; |
|
||||
print "\t\t<FRAME name=\"rptdtl003\" frameborder=0 src=\"$urlroot/likert_wall_A_104.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\">\n"; |
|
||||
print "\t</FRAMESET>\n"; |
|
||||
print "</FRAMESET>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
|
|
||||
1 ; |
|
||||
|
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,203 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: login.pl,v 1.16 2006/10/19 17:35:29 psims Exp $ |
|
||||
# |
|
||||
# Source File: login.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&traceoutput("login.pl"); # TRACE IF ACTIVE |
|
||||
|
|
||||
&app_initialize; |
|
||||
$SESSION{'temptime'} = time(); |
|
||||
|
|
||||
$SESSION{'clid'} = $FORM{'clid'}; |
|
||||
$SESSION{'lang'} = $FORM{'lang'}; |
|
||||
&get_client_configuration(); |
|
||||
&traceoutput("login.pl:$FORM{'clid'}:$FORM{'uid'}:$FORM{'pwd'}"); # TRACE IF ACTIVE |
|
||||
&setbrowsertype(); |
|
||||
|
|
||||
## DED Patch for secure_html/tests dir permission problem 2006/10/11 |
|
||||
if (! -x $testroot) { |
|
||||
print STDERR "PERMS: $testroot is not X\n"; |
|
||||
chmod(0777, $testroot); |
|
||||
} |
|
||||
|
|
||||
if ($FORM{'selfregister'} eq "Y") { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
$CANDIDATE{'new'}="Y"; |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} elsif (&verifyaccess) { |
|
||||
&init_session; |
|
||||
&LanguageSupportInit(); |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "1"); |
|
||||
$FORM{'notice'} = $SYSTEM{'message'}; |
|
||||
|
|
||||
### For redirect to regcnd & regsas |
|
||||
$vars{'tid'} = $SESSION{'tid'}; |
|
||||
$vars{'lang'} = $SESSION{'lang'}; |
|
||||
$vars{'badid'} = $FORM{'badid'} unless !(defined($FORM{'badid'})); #This is used if badid is passed from regsas for autorefresh location trick |
|
||||
$vars{'direction'} = $FORM{'direction'} unless !(defined($FORM{'direction'})); |
|
||||
|
|
||||
if ($SESSION{'taclid'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&set_session($SESSION{'tid'},'taclauthtests',$SESSION{'taclauthtests'}); |
|
||||
&set_session($SESSION{'tid'},'uid',$SESSION{'taclid'}); |
|
||||
if ($FORM{'pwd'} eq '_____') { |
|
||||
&get_tacl_profile("regauto"); |
|
||||
®dusr("regauto"); |
|
||||
} else { |
|
||||
&get_tacl_profile(); |
|
||||
®dusr("regtacl"); |
|
||||
} |
|
||||
} elsif ($FORM{'sas'} ne '') { |
|
||||
## ^ support for wilcard login |
|
||||
# register an account to the candidate |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
#®dusr("regsas"); |
|
||||
&redirect("regsas", \%vars); |
|
||||
} else { |
|
||||
if ($FORM{'sadm'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($SESSION{'uac'} eq 'gadmin') { |
|
||||
# Site administration |
|
||||
$CLIENT{'active'} = "X"; |
|
||||
$CLIENT{'logo'} = "<IMG SRC=\"$PATHS{'graphroot'}/logo.gif\" BORDER=0>\n"; |
|
||||
$CLIENT{'clorg'} = "ACTS Corporation"; |
|
||||
®dusr("frsadmin"); |
|
||||
} elsif ($SESSION{'uac'} =~ /txlatr./ ) { |
|
||||
($FORM{'uac'},$FORM{'lang'}) = split(/\./, $SESSION{'uac'}); |
|
||||
$CLIENT{'active'} = "X"; |
|
||||
$CLIENT{'logo'} = "<IMG SRC=\"$PATHS{'graphroot'}/logo.gif\" BORDER=0>\n"; |
|
||||
$CLIENT{'clorg'} = "ACTS Corporation"; |
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD>\n"; |
|
||||
print "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL=$PATHS{'cgiroot'}/Interpreter.pl?tid=$SESSION{'tid'}&lang=$FORM{'lang'}\">\n"; |
|
||||
print "</HEAD>\n"; |
|
||||
print "<BODY>\n"; |
|
||||
print "</BODY>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
} elsif ($SESSION{'uac'} eq 'madmin') { |
|
||||
# Multiple-client admin |
|
||||
®dusr("madmin"); |
|
||||
} else { |
|
||||
# Client Test Administration |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
®dusr("frsadmin"); |
|
||||
} |
|
||||
} else { |
|
||||
if ($FORM{'tadm'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($SESSION{'uac'} eq 'madmin') { |
|
||||
# Multiple-client admin |
|
||||
®dusr("madmin"); |
|
||||
} else { |
|
||||
# Client Test Administration |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
®dusr("frsadmin"); |
|
||||
} |
|
||||
} else { |
|
||||
if (&checkinprogress($SESSION{'clid'}, $FORM{'uid'}) ) { |
|
||||
# resume test at point of pause |
|
||||
&resumetest; |
|
||||
} else { |
|
||||
if ($FORM{'cnd'} ne '') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}, $opts); |
|
||||
#print STDERR "clid: $SESSION{'clid'}, uid: $FORM{'uid'}, opts: $opts\n"; |
|
||||
if ($CANDIDATE{'grpowner'} eq 'Y') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("frcnd"); |
|
||||
} elsif ($CANDIDATE{'registrar'} eq 'Y') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("frcnd"); |
|
||||
} else { |
|
||||
&redirect("regcnd", \%vars); |
|
||||
} |
|
||||
} else { |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}); |
|
||||
#®dusr("regsas"); |
|
||||
&redirect("regsas", \%vars); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
# Load Index.html |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($FORM{'home'} eq 'client') { |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
@lines = &get_template("cindex"); |
|
||||
} else { |
|
||||
@lines = &get_template("shome"); |
|
||||
} |
|
||||
if ($ipfilter ne '') { |
|
||||
if ($ipfilter =~ /$ENV{'REMOTE_ADDR'}/ ) { |
|
||||
# ip blocked |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"System Maintenance In Progress.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::loginfo("Incorrect passwd 4"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgipb.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
if ($SYSTEM{'IP_ACCESS_FILTER'} ne '') { |
|
||||
if ($SYSTEM{'IP_ACCESS_FILTER'} =~ /$ENV{'REMOTE_ADDR'}/ ) { |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
&logger::loginfo("Incorrect passwd 3"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::loginfo("Incorrect passwd 2"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgipb.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
&logger::loginfo("Incorrect passwd 1"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
foreach $line (@lines) { |
|
||||
$line = &xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub resumetest { |
|
||||
print "RESUMING TEST<BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"tid\" VALUE=\"$FORM{'tid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uid\" VALUE=\"$FORM{'uid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"pwd\" VALUE=\"$FORM{'pwd'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uac\" VALUE=\"$FORM{'uac'}\"><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub test { |
|
||||
print "<INPUT TYPE=TEXT NAME=\"tid\" VALUE=\"$FORM{'tid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uid\" VALUE=\"$FORM{'uid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"pwd\" VALUE=\"$FORM{'pwd'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uac\" VALUE=\"$FORM{'uac'}\"><BR>\n"; |
|
||||
&showenv; |
|
||||
} |
|
||||
|
|
||||
@ -1,224 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: login.pl,v 1.16 2006/10/19 17:35:29 psims Exp $ |
|
||||
# |
|
||||
# Source File: login.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&traceoutput("login.pl"); # TRACE IF ACTIVE |
|
||||
|
|
||||
&app_initialize; |
|
||||
$SESSION{'temptime'} = time(); |
|
||||
|
|
||||
$SESSION{'clid'} = $FORM{'clid'}; |
|
||||
$SESSION{'lang'} = $FORM{'lang'}; |
|
||||
&get_client_configuration(); |
|
||||
&traceoutput("login.pl:$FORM{'clid'}:$FORM{'uid'}:$FORM{'pwd'}"); # TRACE IF ACTIVE |
|
||||
&setbrowsertype(); |
|
||||
|
|
||||
## DED Patch for secure_html/tests dir permission problem 2006/10/11 |
|
||||
if (! -x $testroot) { |
|
||||
print STDERR "PERMS: $testroot is not X\n"; |
|
||||
chmod(0777, $testroot); |
|
||||
} |
|
||||
|
|
||||
if ($FORM{'selfregister'} eq "Y") { |
|
||||
unless ($SESSION{'clid'}) { |
|
||||
warn "ERROR: Empty Client ID in Form $FORM{'clid'} " ; |
|
||||
&show_illegal_access_warning("user"); |
|
||||
exit(); |
|
||||
} |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
unless (%CLIENT) { |
|
||||
warn "ERROR: Invalid Client ID $FORM{'clid'} " ; |
|
||||
&show_illegal_access_warning("user"); |
|
||||
exit(); |
|
||||
} |
|
||||
$CANDIDATE{'new'}="Y"; |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} elsif (&verifyaccess) { |
|
||||
&init_session; |
|
||||
&LanguageSupportInit(); |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "1"); |
|
||||
$FORM{'notice'} = $SYSTEM{'message'}; |
|
||||
|
|
||||
### For redirect to regcnd & regsas |
|
||||
$vars{'tid'} = $SESSION{'tid'}; |
|
||||
$vars{'lang'} = $SESSION{'lang'}; |
|
||||
$vars{'badid'} = $FORM{'badid'} unless !(defined($FORM{'badid'})); #This is used if badid is passed from regsas for autorefresh location trick |
|
||||
$vars{'direction'} = $FORM{'direction'} unless !(defined($FORM{'direction'})); |
|
||||
unless ($SESSION{'clid'}) { |
|
||||
warn "ERROR: Empty Client ID in Form $FORM{'clid'} " ; |
|
||||
&show_illegal_access_warning("user"); |
|
||||
exit(); |
|
||||
} |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
unless (%CLIENT || $SESSION{'clid'} eq 'std') { |
|
||||
warn "ERROR: Invalid Client ID $FORM{'clid'} " ; |
|
||||
&show_illegal_access_warning("user"); |
|
||||
exit(); |
|
||||
} |
|
||||
if ($SESSION{'taclid'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&set_session($SESSION{'tid'},'taclauthtests',$SESSION{'taclauthtests'}); |
|
||||
&set_session($SESSION{'tid'},'uid',$SESSION{'taclid'}); |
|
||||
if ($FORM{'pwd'} eq '_____') { |
|
||||
&get_tacl_profile("regauto"); |
|
||||
®dusr("regauto"); |
|
||||
} else { |
|
||||
&get_tacl_profile(); |
|
||||
®dusr("regtacl"); |
|
||||
} |
|
||||
} elsif ($FORM{'sas'} ne '') { |
|
||||
## ^ support for wilcard login |
|
||||
# register an account to the candidate |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
unless ($SESSION{'uid'}) { |
|
||||
warn "ERROR: Empty Candidate ID in Session data " ; |
|
||||
} |
|
||||
&get_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
#®dusr("regsas"); |
|
||||
&redirect("regsas", \%vars); |
|
||||
} else { |
|
||||
if ($FORM{'sadm'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($SESSION{'uac'} eq 'gadmin') { |
|
||||
# Site administration |
|
||||
$CLIENT{'active'} = "X"; |
|
||||
$CLIENT{'logo'} = "<IMG SRC=\"$PATHS{'graphroot'}/logo.gif\" BORDER=0>\n"; |
|
||||
$CLIENT{'clorg'} = "ACTS Corporation"; |
|
||||
®dusr("frsadmin"); |
|
||||
} elsif ($SESSION{'uac'} =~ /txlatr./ ) { |
|
||||
($FORM{'uac'},$FORM{'lang'}) = split(/\./, $SESSION{'uac'}); |
|
||||
$CLIENT{'active'} = "X"; |
|
||||
$CLIENT{'logo'} = "<IMG SRC=\"$PATHS{'graphroot'}/logo.gif\" BORDER=0>\n"; |
|
||||
$CLIENT{'clorg'} = "ACTS Corporation"; |
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD>\n"; |
|
||||
print "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL=$PATHS{'cgiroot'}/Interpreter.pl?tid=$SESSION{'tid'}&lang=$FORM{'lang'}\">\n"; |
|
||||
print "</HEAD>\n"; |
|
||||
print "<BODY>\n"; |
|
||||
print "</BODY>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
} elsif ($SESSION{'uac'} eq 'madmin') { |
|
||||
# Multiple-client admin |
|
||||
®dusr("madmin"); |
|
||||
} else { |
|
||||
# Client Test Administration |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
®dusr("frsadmin"); |
|
||||
} |
|
||||
} else { |
|
||||
if ($FORM{'tadm'} ne '') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($SESSION{'uac'} eq 'madmin') { |
|
||||
# Multiple-client admin |
|
||||
®dusr("madmin"); |
|
||||
} else { |
|
||||
# Client Test Administration |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
®dusr("frsadmin"); |
|
||||
} |
|
||||
} else { |
|
||||
if (&checkinprogress($SESSION{'clid'}, $FORM{'uid'}) ) { |
|
||||
# resume test at point of pause |
|
||||
&resumetest; |
|
||||
} else { |
|
||||
if ($FORM{'cnd'} ne '') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}, $opts); |
|
||||
#print STDERR "clid: $SESSION{'clid'}, uid: $FORM{'uid'}, opts: $opts\n"; |
|
||||
if ($CANDIDATE{'grpowner'} eq 'Y') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("frcnd"); |
|
||||
} elsif ($CANDIDATE{'registrar'} eq 'Y') { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("frcnd"); |
|
||||
} else { |
|
||||
&redirect("regcnd", \%vars); |
|
||||
} |
|
||||
} else { |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}); |
|
||||
#®dusr("regsas"); |
|
||||
&redirect("regsas", \%vars); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
# Load Index.html |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($FORM{'home'} eq 'client') { |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
@lines = &get_template("cindex"); |
|
||||
} else { |
|
||||
@lines = &get_template("shome"); |
|
||||
} |
|
||||
if ($ipfilter ne '') { |
|
||||
if ($ipfilter =~ /$ENV{'REMOTE_ADDR'}/ ) { |
|
||||
# ip blocked |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"System Maintenance In Progress.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::loginfo("Incorrect passwd 4"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgipb.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
if ($SYSTEM{'IP_ACCESS_FILTER'} ne '') { |
|
||||
if ($SYSTEM{'IP_ACCESS_FILTER'} =~ /$ENV{'REMOTE_ADDR'}/ ) { |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
&logger::loginfo("Incorrect passwd 3"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::loginfo("Incorrect passwd 2"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgipb.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} |
|
||||
} else { |
|
||||
if ($FORM{'sas'} eq '') { |
|
||||
# uid or password were incorrect |
|
||||
&logger::loginfo("Incorrect passwd 1"); |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgbpw.gif\" ALT=\"Incorrect Password.\" BORDER=0>"; |
|
||||
} else { |
|
||||
# uid is used |
|
||||
$SYSTEM{'message'} = "<IMG SRC=\"$graphroot/msgidu.gif\" ALT=\"Requested Login ID is not available.\" BORDER=0>"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
foreach $line (@lines) { |
|
||||
$line = &xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub resumetest { |
|
||||
print "RESUMING TEST<BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"tid\" VALUE=\"$FORM{'tid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uid\" VALUE=\"$FORM{'uid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"pwd\" VALUE=\"$FORM{'pwd'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uac\" VALUE=\"$FORM{'uac'}\"><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub test { |
|
||||
print "<INPUT TYPE=TEXT NAME=\"tid\" VALUE=\"$FORM{'tid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uid\" VALUE=\"$FORM{'uid'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"pwd\" VALUE=\"$FORM{'pwd'}\"><BR>\n"; |
|
||||
print "<INPUT TYPE=TEXT NAME=\"uac\" VALUE=\"$FORM{'uac'}\"><BR>\n"; |
|
||||
&showenv; |
|
||||
} |
|
||||
|
|
||||
@ -1,98 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: maillib.pl,v 1.2 2004/01/13 19:22:04 jeffo Exp $ |
|
||||
# |
|
||||
# Source File: maillib.pl |
|
||||
|
|
||||
|
|
||||
use Net::SMTP; |
|
||||
|
|
||||
#sub send_mail { |
|
||||
# open(SENDMAIL, "|/usr/lib/sendmail -oi -t") |
|
||||
# or $msg2 = "Can't fork for sendmail: $!\n"; |
|
||||
# print SENDMAIL <<"EOF"; |
|
||||
#From: $_[0] |
|
||||
#To: $_[1] |
|
||||
#Subject: $_[2] |
|
||||
# |
|
||||
# |
|
||||
# |
|
||||
#$_[3] |
|
||||
#EOF |
|
||||
#close(SENDMAIL) or $msg2 = "sendmail didn't close nicely"; |
|
||||
#} |
|
||||
|
|
||||
sub send_mail { |
|
||||
$subj = $_[2]; |
|
||||
warn "maillib.pl send_mail called SUBJ is $subj X" ; |
|
||||
warn "maillib.pl send_mail called TO is $_[1] FROM is $_[0] X" ; |
|
||||
warn "send_mail called mail_server_domain is $mail_server_domain X" ; |
|
||||
if ( $subj =~ /\:/) { |
|
||||
$maildir = join( $pathsep, $pubroot, $SESSION{'clid'}, "notify"); |
|
||||
$mmdate = &format_date_time("dd-mmm-yyyy", time, "0"); |
|
||||
$mmtime = &format_date_time("hh:nn:ss", time, "0"); |
|
||||
$filename=join(' ', $_[2],$mmdate,$mmtime); |
|
||||
$filename =~ s/ /_/g; |
|
||||
$trash = join( $pathsep, $maildir, $filename); |
|
||||
if (open( MAILFILE, ">$trash" )) { |
|
||||
print MAILFILE "From:$_[0]\nTo: $_[1]\nSubject: $_[2]\n$_[3]\n"; |
|
||||
close MAILFILE; |
|
||||
} |
|
||||
} |
|
||||
#v wac add ability to send to a list of recipients 6/18/02, adapt W2K fix from 8/21/01 |
|
||||
@recipients = split(/\,/, $_[1]); |
|
||||
|
|
||||
$trash = join( $pathsep, $secroot, "debug.txt"); |
|
||||
open( DBGFILE, ">>$trash" ) || return 0; |
|
||||
$smtp = Net::SMTP -> new ($mail_server_domain, |
|
||||
Timeout => '60' |
|
||||
); |
|
||||
print DBGFILE "MAIL: mark\n"; |
|
||||
#print DBGFILE "MAIL: new\n"; |
|
||||
$smtp-> mail ("$_[0]"); |
|
||||
#print DBGFILE "MAIL: from\n"; |
|
||||
|
|
||||
foreach $recipient (@recipients) { |
|
||||
$smtp-> recipient ("$recipient", |
|
||||
Skipbad => TRUE); |
|
||||
} |
|
||||
|
|
||||
#print DBGFILE "MAIL: recips specified\n"; |
|
||||
$smtp-> data(); |
|
||||
$smtp -> datasend ("From: $_[0]\nTo: $_[1]\nSubject: $_[2]\n$_[3]"); |
|
||||
$smtp -> dataend; |
|
||||
#print DBGFILE "MAIL: data\n"; |
|
||||
$smtp -> quit; |
|
||||
#print DBGFILE "MAIL: done\n"; |
|
||||
close DBGFILE; |
|
||||
} |
|
||||
|
|
||||
#wac ^ replaced whole subroutine, had to adapt to retain debug statements. |
|
||||
|
|
||||
sub send_illegal_attempt { |
|
||||
$capturedenv = ""; |
|
||||
for (keys %ENV) { |
|
||||
$capturedenv = join('', $capturedenv, "$_ = $ENV{$_}\r\n"); |
|
||||
} |
|
||||
$mmdate = &format_date_time("dd-mmm-yyyy", time, "0"); |
|
||||
$mmtime = &format_date_time("hh:nn:ss", time, "0"); |
|
||||
$mmsubj = "ILLEGAL ACCESS ATTEMPT"; |
|
||||
$mmbody = "Date: $mmdate |
|
||||
An illegal attempt to access the site has occurred. |
|
||||
|
|
||||
USER_AGENT: $ENV{'HTTP_USER_AGENT'} |
|
||||
REMOTE_ADDR: $ENV{'REMOTE_ADDR'} |
|
||||
HTTP_REFERER: $ENV{'HTTP_REFERER'} |
|
||||
REQUEST_METHOD: $ENV{'REQUEST_METHOD'} |
|
||||
SERVER_PORT: $ENV{'SERVER_PORT'} |
|
||||
QUERY_STRING: $qstr |
|
||||
|
|
||||
ENVIRONMENT: |
|
||||
$capturedenv |
|
||||
"; |
|
||||
&send_mail($mmautontfyfrom, $mmautontfyto, $mmsubj, $mmbody); |
|
||||
} |
|
||||
|
|
||||
|
|
||||
# end with True because this is a require file |
|
||||
1 |
|
||||
@ -1,224 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: qlib.pl,v 1.4 2004/10/08 17:38:09 ddoughty Exp $ |
|
||||
# Source File: qlib.pl |
|
||||
|
|
||||
use CGI qw/:standard/; |
|
||||
|
|
||||
sub build_question_select_list { |
|
||||
$questionlist = ""; |
|
||||
@questions=&get_question_list($TEST{'id'}, $SESSION{'clid'}); |
|
||||
$qflds = $questions[0]; |
|
||||
chop($qflds); |
|
||||
@qflds = split(/&/, $qflds); |
|
||||
for (0 .. $#qflds) { |
|
||||
$QFIELDS{$qflds[$_]} = $_; |
|
||||
} |
|
||||
$idxid = $QFIELDS{'id'}; |
|
||||
$idxqtp = $QFIELDS{'qtp'}; |
|
||||
$idxqil = $QFIELDS{'qil'}; |
|
||||
$idxsub = $QFIELDS{'subj'}; |
|
||||
$idxtxt = $QFIELDS{'qtx'}; |
|
||||
@qflds = (); |
|
||||
$qflds=""; |
|
||||
for (1 .. $#questions) { |
|
||||
$qflds = $questions[$_]; |
|
||||
chop ($qflds); |
|
||||
@qdata = split(/&/, $qflds); |
|
||||
($trash, $qnum) = split(/\./, $qdata[$idxid]); |
|
||||
$qobsind=($qdata[$idxqil] eq 'Y') ? '*' : "\ "; |
|
||||
### DED 9/11/02 Added marker for entry questions |
|
||||
$qentind=($TEST{'qent'} =~ /$qnum/) ? '>' : "\ "; |
|
||||
$qtext = substr($qdata[$idxtxt],0,20); |
|
||||
$listtext = sprintf("%s %3s %10s : %20s", $qnum, $qdata[$idxqtp], $qdata[$idxsub], $qtext); |
|
||||
$questionlist = join('', $questionlist, "<OPTION VALUE=\"$qdata[$idxid]\">$qobsind$qentind $listtext</OPTION>\n"); |
|
||||
} |
|
||||
@qdata = (); |
|
||||
@questions = (); |
|
||||
$TEST{'questionlist'} = $questionlist; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub build_question_answer_list { |
|
||||
$quesid = ""; |
|
||||
$questxt = ""; |
|
||||
$quesans = ""; |
|
||||
$numans = 0; |
|
||||
@questions=&get_question_list($TEST{'id'}, $SESSION{'clid'}); |
|
||||
$qflds = $questions[0]; |
|
||||
chop($qflds); |
|
||||
@qflds = split(/&/, $qflds); |
|
||||
for (0 .. $#qflds) { |
|
||||
$QFIELDS{$qflds[$_]} = $_; |
|
||||
} |
|
||||
$idxid = $QFIELDS{'id'}; |
|
||||
$idxqtp = $QFIELDS{'qtp'}; |
|
||||
$idxtxt = $QFIELDS{'subj'}; |
|
||||
$idxqtx = $QFIELDS{'qtx'}; |
|
||||
$idxqca = $QFIELDS{'qca'}; |
|
||||
$idxqia = $QFIELDS{'qia'}; |
|
||||
@qflds = (); |
|
||||
$qflds=""; |
|
||||
for (1 .. $#questions) { |
|
||||
$qflds = $questions[$_]; |
|
||||
chop ($qflds); |
|
||||
@qdata = split(/&/, $qflds); |
|
||||
($trash, $qnum) = split(/\./, $qdata[$idxid]); |
|
||||
$quesid=join('&',$quesid,$qdata[$idxid]); |
|
||||
$questxt=join('&',$questxt,$qdata[$idxqtx]); |
|
||||
if ($qdata[$idxqtp] eq 'mcs' || $qdata[$idxqtp] eq 'mca' || $qdata[$idxqtp] eq 'tf' || $qdata[$idxqtp] eq 'esa') { |
|
||||
if ($qdata[$idxqca] eq '') { |
|
||||
$ansdata=$qdata[$idxqia]; |
|
||||
} elsif ($qdata[$idxqia] eq '') { |
|
||||
$ansdata=$qdata[$idxqca]; |
|
||||
} else { |
|
||||
$ansdata=join('\;',$qdata[$idxqca],$qdata[$idxqia]); |
|
||||
} |
|
||||
} elsif ($qdata[$idxqtp] eq 'mcm') { |
|
||||
if ($qdata[$idxqca] eq '') { |
|
||||
$ansdata=$qdata[$idxqia]; |
|
||||
} elsif ($qdata[$idxqia] eq '') { |
|
||||
$ansdata=$qdata[$idxqca]; |
|
||||
} else { |
|
||||
$ansdata=join('',$qdata[$idxqca],$qdata[$idxqia]); |
|
||||
} |
|
||||
|
|
||||
} else { |
|
||||
$ansdata=""; |
|
||||
} |
|
||||
$ansdata =~ s/^\;//; |
|
||||
$ansdata =~ s/\;$//; |
|
||||
@ansdata=split('\;',$ansdata); |
|
||||
if ($#ansdata > $numans) { $numans = $#ansdata } |
|
||||
$quesans=join('&',$quesans,$ansdata); |
|
||||
} |
|
||||
$quesid=substr($quesid,1); |
|
||||
$questxt=substr($questxt,1); |
|
||||
$quesans=substr($quesans,1); |
|
||||
@qdata = (); |
|
||||
@questions = (); |
|
||||
@ansdata=(); |
|
||||
} |
|
||||
|
|
||||
#($TEST{'id'}, $SESSION{'clid'}, $FORM{'qid'}) |
|
||||
sub put_question_image { |
|
||||
my ($clid,$qid,$upfilename) = @_; |
|
||||
my $upfile; |
|
||||
my $msg; |
|
||||
my $chmodok; |
|
||||
if ($upfilename eq '') { |
|
||||
$upfilename = "$clid.$qid"; |
|
||||
} |
|
||||
my $upimg = upload($upfilename); |
|
||||
my @fileparts = split(/\./, param($upfilename)); |
|
||||
my $question_image_ext = $fileparts[$#fileparts]; |
|
||||
@fileparts = (); |
|
||||
if ($question_image_ext ne "" && $SYSTEM{'supportedimagemedia'} =~ /$question_image_ext/i ) { |
|
||||
# remove any old images for this question |
|
||||
&remove_question_image($clid, $qid); |
|
||||
# write the uploaded file |
|
||||
$upfile = join($pathsep, $testgraphic, "$clid.$qid.$question_image_ext"); |
|
||||
open (OUTFILE, ">$upfile") or $msg="failed"; |
|
||||
if ($msg ne "failed") { |
|
||||
binmode(OUTFILE); |
|
||||
while ($bytesread=read($upimg,$buffer,1024)) { |
|
||||
print OUTFILE $buffer; |
|
||||
} |
|
||||
close OUTFILE; |
|
||||
$chmodok = chmod 0666, $upfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
#($TEST{'id'}, $SESSION{'clid'}, $FORM{'qid'}) |
|
||||
sub remove_question_image { |
|
||||
my ($clid,$qid) = @_; |
|
||||
my $prefile; |
|
||||
my $existingfile; |
|
||||
my $cnt; |
|
||||
my @suexts = split(/\;/, $SYSTEM{'supportedimagemedia'}); |
|
||||
foreach $suext (@suexts) { |
|
||||
$prefile = join($pathsep, $testgraphic, "$clid.$qid"); |
|
||||
$existingfile=&file_exists_with_extension($prefile, $suext); |
|
||||
if ($existingfile ne '') { |
|
||||
$cnt = unlink $existingfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub copy_question_image { |
|
||||
my ($clid,$newqid,$qid) = @_; |
|
||||
my $prefile; |
|
||||
my $existingfile; |
|
||||
my $imgdata; |
|
||||
my $fsize; |
|
||||
my $chmodok; |
|
||||
my $msg; |
|
||||
my @suexts = split(/\;/, $SYSTEM{'supportedimagemedia'}); |
|
||||
foreach $suext (@suexts) { |
|
||||
$prefile = join($pathsep, $testgraphic, "$clid.$newqid"); |
|
||||
$existingfile=&file_exists_with_extension($prefile, $suext); |
|
||||
if ($existingfile ne '') { |
|
||||
$prefile = $existingfile; |
|
||||
$prefile =~ s/$newqid/$qid/g; |
|
||||
|
|
||||
open (IMGFILE, "<$existingfile"); |
|
||||
binmode(IMGFILE); |
|
||||
$fsize = (stat(IMGFILE))[7]; |
|
||||
read(IMGFILE, $imgdata, $fsize); |
|
||||
close IMGFILE; |
|
||||
|
|
||||
open (IMGFILE, ">$prefile") or $msg="failed"; |
|
||||
if ($msg ne "failed") { |
|
||||
binmode(IMGFILE); |
|
||||
print IMGFILE $imgdata; |
|
||||
close IMGFILE; |
|
||||
$chmodok = chmod 0666, $prefile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub set_thumbnail { |
|
||||
$htmlreference=""; |
|
||||
if ($QUESTION{'new'} eq "Y") { |
|
||||
if ($QUESTION{'qim'} ne '0') { |
|
||||
$imgfile = $FORM{'localimg'}; |
|
||||
if ($_[0] eq '1') { |
|
||||
$htmlreference = "<A NAME=\"qimage\" HREF=\"file:///$imgfile\" TARGET=\"illustrated\">View</A>\n"; |
|
||||
} elsif ($_[0] eq '2') { |
|
||||
$htmlreference = "<IMG NAME=\"qimage\" SRC=\"file:///$imgfile\">\n"; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
&get_question_definition($TEST{'id'}, $SESSION{'clid'}, $QUESTION{'id'}); |
|
||||
if ($QUESTION{'qim'} ne '0') { |
|
||||
if ($FORM{'localimg'} ne '') { |
|
||||
if ($QUESTION{'qim'} ne '0') { |
|
||||
$imgfile = $FORM{'localimg'}; |
|
||||
if ($_[0] eq '1') { |
|
||||
$htmlreference = "<A NAME=\"qimage\" HREF=\"file:///$imgfile\" TARGET=\"illustrated\">View</A>\n"; |
|
||||
} elsif ($_[0] eq '2') { |
|
||||
$htmlreference = "<IMG NAME=\"qimage\" SRC=\"file:///$imgfile\">\n"; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
$imgbase = join($pathsep, $testgraphic, "$SESSION{'clid'}.$QUESTION{'id'}"); |
|
||||
$imgextopts = join('', $SYSTEM{'supportedimagemedia'}, |
|
||||
$SYSTEM{'supportedaudiomedia'}, |
|
||||
$SYSTEM{'supportedvideomedia'}); |
|
||||
$imgfile = &file_exists_with_extension($imgbase, $imgextopts); |
|
||||
$imgfile =~ s/$testgraphic//g; |
|
||||
$imgfile =~ s/\///g; |
|
||||
if ($_[0] eq '1') { |
|
||||
$htmlreference = "<A NAME=\"qimage\" HREF=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$imgfile\" TARGET=\"illustrated\">View</A>\n"; |
|
||||
} elsif ($_[0] eq '2') { |
|
||||
$htmlreference = "<IMG NAME=\"qimage\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$imgfile\">\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
return $htmlreference; |
|
||||
} |
|
||||
# end with True because this is a require file |
|
||||
1 |
|
||||
@ -1,152 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: $ |
|
||||
# |
|
||||
# Source File: questionslib.pl |
|
||||
# --- Originally pulled from testdata.pl and converted to a library PERL file. |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Reporter; |
|
||||
use Data::Dumper; |
|
||||
require 'cybertestlib.pl' ; |
|
||||
require 'sitecfg.pl' ; |
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST %SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT %SUBTEST_RESPONSES); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot $testgraphic $graphroot); |
|
||||
|
|
||||
|
|
||||
sub get_question_definitions { |
|
||||
my ($clid, $testid) = @_; |
|
||||
my $qcount = 0; |
|
||||
my @questions = () ; |
|
||||
my @qrecs = &get_question_list($testid, $clid); |
|
||||
chomp $qrecs[0]; |
|
||||
my @flds = split(/&/,shift(@qrecs)); |
|
||||
foreach my $qrec (@qrecs) { |
|
||||
chomp ($qrec); |
|
||||
#($id, $qtyp) = split(/&/, $qrec); |
|
||||
my @rowdata = split(/&/, $qrec); |
|
||||
my $i=0; |
|
||||
my $question = {}; |
|
||||
@{$question}{@flds} = @rowdata; |
|
||||
($question->{'subj'},$question->{'skilllevel'}) = split(/\./,$question->{'subj'}); |
|
||||
$question->{'tf'} = ($question->{'qtp'} eq 'tf') ? "SELECTED" : ""; |
|
||||
$question->{'mcs'} = ($question->{'qtp'} eq 'mcs') ? "SELECTED" : ""; |
|
||||
$question->{'mcm'} = ($question->{'qtp'} eq 'mcm') ? "SELECTED" : ""; |
|
||||
$question->{'esa'} = ($question->{'qtp'} eq 'esa') ? "SELECTED" : ""; |
|
||||
$question->{'nrt'} = ($question->{'qtp'} eq 'nrt') ? "SELECTED" : ""; |
|
||||
$question->{'qtx'} =~ s/\;/\n/g; |
|
||||
$question->{'qca'} =~ s/\;/\n/g; |
|
||||
$question->{'qia'} =~ s/\;/\n/g; |
|
||||
|
|
||||
$question->{'lbla'} = ($question->{'qalb'} eq 'a') ? "SELECTED" : ""; |
|
||||
$question->{'lblA'} = ($question->{'qalb'} eq 'A') ? "SELECTED" : ""; |
|
||||
$question->{'lbln'} = ($question->{'qalb'} eq 'n') ? "SELECTED" : ""; |
|
||||
$question->{'lblr'} = ($question->{'qalb'} eq 'r') ? "SELECTED" : ""; |
|
||||
$question->{'lblR'} = ($question->{'qalb'} eq 'R') ? "SELECTED" : ""; |
|
||||
|
|
||||
$question->{'tft'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'TRUE') ? "CHECKED" : ""; |
|
||||
$question->{'tff'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'FALSE') ? "CHECKED" : ""; |
|
||||
$question->{'tfy'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'YES') ? "CHECKED" : ""; |
|
||||
$question->{'tfn'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'NO') ? "CHECKED" : ""; |
|
||||
|
|
||||
$question->{'qim0'} = ($question->{'qim'} eq '0') ? "SELECTED" : ""; |
|
||||
$question->{'qim1'} = ""; |
|
||||
$question->{'qim2'} = ""; |
|
||||
my $illus = join($pathsep, $testgraphic, "$clid.$question->{'id'}"); |
|
||||
my $supportedmedia = join(';', $SYSTEM{'supportedimagemedia'}, $SYSTEM{'supportedaudiomedia'}, $SYSTEM{'supportedvideomedia'}); |
|
||||
my $illusfile = &file_exists_with_extension($illus, $supportedmedia); |
|
||||
$question->{'illustration'} = ""; |
|
||||
$question->{'defthumbnail'} = "<IMG NAME=\"qimage\" SRC=\"$graphroot/noimageassigned.gif\" width=100 BORDER=0>"; |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'qim1'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '2') { |
|
||||
$question->{'qim2'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '3' ) { |
|
||||
$question->{'qim3'} = "SELECTED"; |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$question->{'flr'}\" TARGET=\"illustrated\">Reference Page</A>"; |
|
||||
} |
|
||||
if ($illusfile ne '') { |
|
||||
my @filesegs = split(/\./, $illusfile); |
|
||||
my $fext = $filesegs[$#filesegs]; |
|
||||
@filesegs = () ; |
|
||||
if ($SYSTEM{'supportedimagemedia'} =~ m/$fext/i ) { |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\">Illustration</A>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} else { |
|
||||
$question->{'illustration'} = "<IMG NAME=\"qimage\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" BORDER=0>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} |
|
||||
} elsif ($SYSTEM{'supportedvideomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" CONTROLS=\"console\" HIDDEN=\"false\">"; |
|
||||
} elsif ($SYSTEM{'supportedaudiomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" WIDTH=\"100\" HEIGHT=\"50\" CONTROLS=\"small console\" HIDDEN=\"false\">"; |
|
||||
} |
|
||||
} |
|
||||
#if ($question->{'qnxt'} eq '' ) { |
|
||||
#$question->{'qnxt'} = ($qcount < $#qrecs) ? $qcount + 1 : $#qrecs; |
|
||||
#} else { |
|
||||
#if ($question->{'qnxt'} > $#qrecs) { |
|
||||
#$question->{'qnxt'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
#if ($question->{'qprv'} eq '' ) { |
|
||||
#$question->{'qprv'} = ($qcount == 1) ? 1 : $qcount - 1; |
|
||||
#} else { |
|
||||
#if ($question->{'qprv'} > $#qrecs) { |
|
||||
#$question->{'qprv'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
$question->{'totdef'} = $#qrecs; |
|
||||
$question->{'chkobs'} = ($question->{'qil'} eq 'Y') ? "CHECKED" : ""; |
|
||||
if ($question->{'qtx'} =~ /:::/) { |
|
||||
($question->{'qtx'}, $question->{'left_be'}, $question->{'right_be'}) = split(/:::/, $question->{'qtx'}); |
|
||||
} |
|
||||
if ($question->{'layout'} =~ /:/) { |
|
||||
($question->{'layout'}, $question->{'anslay'}) = split(/:/, $question->{'layout'}); |
|
||||
$question->{'anslayhchk'} = ($question->{'anslay'} eq 'h') ? "CHECKED" : ""; |
|
||||
} else { |
|
||||
$question->{'anslay'} = ""; |
|
||||
} |
|
||||
$question->{'anslayvchk'} = ($question->{'anslay'} ne 'h') ? "CHECKED" : ""; |
|
||||
$question->{'layout2chk'} = ($question->{'layout'} eq '2') ? "CHECKED" : ""; |
|
||||
$question->{'layout3chk'} = ($question->{'layout'} eq '3') ? "CHECKED" : ""; |
|
||||
$question->{'layout4chk'} = ($question->{'layout'} eq '4') ? "CHECKED" : ""; |
|
||||
$question->{'layout5chk'} = ($question->{'layout'} eq '5') ? "CHECKED" : ""; |
|
||||
$question->{'layout1chk'} = ($question->{'layout'} eq '1') ? "CHECKED" : ""; |
|
||||
if ($question->{'layout'} eq '') { |
|
||||
$question->{'layout'} = '1'; |
|
||||
$question->{'layout1chk'} = "CHECKED"; |
|
||||
} |
|
||||
# sac v start addition for comment input support |
|
||||
my @qflags = split(/\./,$question->{'flags'}); |
|
||||
$question->{'qcmtprmpt'} = $qflags[0]; |
|
||||
$question->{'chkqccmt'} = ($qflags[0] eq 'Y') ? "CHECKED" : ""; |
|
||||
$question->{'qcprmpt'} = ($qflags[0] eq 'Y') ? $qflags[1] : ""; |
|
||||
$question->{'promptcomments'}=""; |
|
||||
if ($qflags[0] eq 'Y') { |
|
||||
$question->{'promptcomments'}=" |
|
||||
<FONT SIZE=\"4\">\ <br> |
|
||||
<b><i>$qflags[1]</i></b><br> |
|
||||
<TEXTAREA NAME=\"qcucmt\" cols=\"50\" rows=\"3\" |
|
||||
wrap=on onKeyPress=\"languagesupport(this)\" |
|
||||
onFocus=\"return tGotFocus(this)\" |
|
||||
onChange=\"return onConvert(this)\"></TEXTAREA> |
|
||||
</FONT><br>\n"; |
|
||||
if (($question->{'layout'} eq '4') || ($question->{'layout'} eq '5') || ($question->{'qtyp'} eq 'nrt')) { |
|
||||
$question->{'promptcomments'}=join('',"\ <br>",$question->{'promptcomments'}); |
|
||||
} else { |
|
||||
$question->{'promptcomments'}=join('',"<tr><td>",$question->{'promptcomments'},"</td></tr>"); |
|
||||
} |
|
||||
} |
|
||||
# sac ^ end addition for comment input support |
|
||||
#return; |
|
||||
push @questions, $question; |
|
||||
} |
|
||||
return \@questions; |
|
||||
} |
|
||||
|
|
||||
1 ; # End of library file. |
|
||||
|
|
||||
@ -1,158 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: $ |
|
||||
# |
|
||||
# Source File: questionslib.pl |
|
||||
# --- Originally pulled from testdata.pl and converted to a library PERL file. |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Reporter; |
|
||||
use Data::Dumper; |
|
||||
require 'cybertestlib.pl' ; |
|
||||
require 'sitecfg.pl' ; |
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST %SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT %SUBTEST_RESPONSES); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot $testgraphic $graphroot); |
|
||||
|
|
||||
|
|
||||
sub get_question_definitions { |
|
||||
my ($clid, $testid) = @_; |
|
||||
my $qcount = 0; |
|
||||
my @questions = () ; |
|
||||
my @qrecs = &get_question_list($testid, $clid); |
|
||||
chomp $qrecs[0]; |
|
||||
my @flds = split(/&/,shift(@qrecs)); |
|
||||
foreach my $qrec (@qrecs) { |
|
||||
chomp ($qrec); |
|
||||
#($id, $qtyp) = split(/&/, $qrec); |
|
||||
my @rowdata = split(/&/, $qrec); |
|
||||
my $i=0; |
|
||||
my $question = {}; |
|
||||
@{$question}{@flds} = @rowdata; |
|
||||
($question->{'subj'},$question->{'skilllevel'}) = split(/\./,$question->{'subj'}); |
|
||||
$question->{'tf'} = ($question->{'qtp'} eq 'tf') ? "SELECTED" : ""; |
|
||||
$question->{'mcs'} = ($question->{'qtp'} eq 'mcs') ? "SELECTED" : ""; |
|
||||
$question->{'mcm'} = ($question->{'qtp'} eq 'mcm') ? "SELECTED" : ""; |
|
||||
$question->{'esa'} = ($question->{'qtp'} eq 'esa') ? "SELECTED" : ""; |
|
||||
$question->{'nrt'} = ($question->{'qtp'} eq 'nrt') ? "SELECTED" : ""; |
|
||||
$question->{'qtx'} =~ s/\;/\n/g; |
|
||||
$question->{'qca'} =~ s/\;/\n/g; |
|
||||
$question->{'qia'} =~ s/\;/\n/g; |
|
||||
|
|
||||
$question->{'lbla'} = ($question->{'qalb'} eq 'a') ? "SELECTED" : ""; |
|
||||
$question->{'lblA'} = ($question->{'qalb'} eq 'A') ? "SELECTED" : ""; |
|
||||
$question->{'lbln'} = ($question->{'qalb'} eq 'n') ? "SELECTED" : ""; |
|
||||
$question->{'lblr'} = ($question->{'qalb'} eq 'r') ? "SELECTED" : ""; |
|
||||
$question->{'lblR'} = ($question->{'qalb'} eq 'R') ? "SELECTED" : ""; |
|
||||
|
|
||||
$question->{'tft'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'TRUE') ? "CHECKED" : ""; |
|
||||
$question->{'tff'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'FALSE') ? "CHECKED" : ""; |
|
||||
$question->{'tfy'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'YES') ? "CHECKED" : ""; |
|
||||
$question->{'tfn'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'NO') ? "CHECKED" : ""; |
|
||||
|
|
||||
$question->{'qim0'} = ($question->{'qim'} eq '0') ? "SELECTED" : ""; |
|
||||
$question->{'qim1'} = ""; |
|
||||
$question->{'qim2'} = ""; |
|
||||
my $illus = join($pathsep, $testgraphic, "$clid.$question->{'id'}"); |
|
||||
my $supportedmedia = join(';', $SYSTEM{'supportedimagemedia'}, $SYSTEM{'supportedaudiomedia'}, $SYSTEM{'supportedvideomedia'}); |
|
||||
my $illusfile = &file_exists_with_extension($illus, $supportedmedia); |
|
||||
$question->{'illustration'} = ""; |
|
||||
$question->{'defthumbnail'} = "<IMG NAME=\"qimage\" SRC=\"$graphroot/noimageassigned.gif\" width=100 BORDER=0>"; |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'qim1'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '2') { |
|
||||
$question->{'qim2'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '3' ) { |
|
||||
$question->{'qim3'} = "SELECTED"; |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$question->{'flr'}\" TARGET=\"illustrated\">Reference Page</A>"; |
|
||||
} |
|
||||
if ($illusfile ne '') { |
|
||||
my @filesegs = split(/\./, $illusfile); |
|
||||
my $fext = $filesegs[$#filesegs]; |
|
||||
@filesegs = () ; |
|
||||
my $IllustrationLabel = "" ; |
|
||||
if ($fext =~ /pdf$/i ) { |
|
||||
$IllustrationLabel = "Click Here" ; |
|
||||
} else { |
|
||||
$IllustrationLabel = "Illustration" ; |
|
||||
} |
|
||||
if ($SYSTEM{'supportedimagemedia'} =~ m/$fext/i ) { |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\">$IllustrationLabel</A>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} else { |
|
||||
$question->{'illustration'} = "<IMG NAME=\"qimage\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" BORDER=0>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} |
|
||||
} elsif ($SYSTEM{'supportedvideomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" CONTROLS=\"console\" HIDDEN=\"false\">"; |
|
||||
} elsif ($SYSTEM{'supportedaudiomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" WIDTH=\"100\" HEIGHT=\"50\" CONTROLS=\"small console\" HIDDEN=\"false\">"; |
|
||||
} |
|
||||
} |
|
||||
#if ($question->{'qnxt'} eq '' ) { |
|
||||
#$question->{'qnxt'} = ($qcount < $#qrecs) ? $qcount + 1 : $#qrecs; |
|
||||
#} else { |
|
||||
#if ($question->{'qnxt'} > $#qrecs) { |
|
||||
#$question->{'qnxt'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
#if ($question->{'qprv'} eq '' ) { |
|
||||
#$question->{'qprv'} = ($qcount == 1) ? 1 : $qcount - 1; |
|
||||
#} else { |
|
||||
#if ($question->{'qprv'} > $#qrecs) { |
|
||||
#$question->{'qprv'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
$question->{'totdef'} = $#qrecs; |
|
||||
$question->{'chkobs'} = ($question->{'qil'} eq 'Y') ? "CHECKED" : ""; |
|
||||
if ($question->{'qtx'} =~ /:::/) { |
|
||||
($question->{'qtx'}, $question->{'left_be'}, $question->{'right_be'}) = split(/:::/, $question->{'qtx'}); |
|
||||
} |
|
||||
if ($question->{'layout'} =~ /:/) { |
|
||||
($question->{'layout'}, $question->{'anslay'}) = split(/:/, $question->{'layout'}); |
|
||||
$question->{'anslayhchk'} = ($question->{'anslay'} eq 'h') ? "CHECKED" : ""; |
|
||||
} else { |
|
||||
$question->{'anslay'} = ""; |
|
||||
} |
|
||||
$question->{'anslayvchk'} = ($question->{'anslay'} ne 'h') ? "CHECKED" : ""; |
|
||||
$question->{'layout2chk'} = ($question->{'layout'} eq '2') ? "CHECKED" : ""; |
|
||||
$question->{'layout3chk'} = ($question->{'layout'} eq '3') ? "CHECKED" : ""; |
|
||||
$question->{'layout4chk'} = ($question->{'layout'} eq '4') ? "CHECKED" : ""; |
|
||||
$question->{'layout5chk'} = ($question->{'layout'} eq '5') ? "CHECKED" : ""; |
|
||||
$question->{'layout1chk'} = ($question->{'layout'} eq '1') ? "CHECKED" : ""; |
|
||||
if ($question->{'layout'} eq '') { |
|
||||
$question->{'layout'} = '1'; |
|
||||
$question->{'layout1chk'} = "CHECKED"; |
|
||||
} |
|
||||
# sac v start addition for comment input support |
|
||||
my @qflags = split(/\./,$question->{'flags'}); |
|
||||
$question->{'qcmtprmpt'} = $qflags[0]; |
|
||||
$question->{'chkqccmt'} = ($qflags[0] eq 'Y') ? "CHECKED" : ""; |
|
||||
$question->{'qcprmpt'} = ($qflags[0] eq 'Y') ? $qflags[1] : ""; |
|
||||
$question->{'promptcomments'}=""; |
|
||||
if ($qflags[0] eq 'Y') { |
|
||||
$question->{'promptcomments'}=" |
|
||||
<FONT SIZE=\"4\">\ <br> |
|
||||
<b><i>$qflags[1]</i></b><br> |
|
||||
<TEXTAREA NAME=\"qcucmt\" cols=\"50\" rows=\"3\" |
|
||||
wrap=on onKeyPress=\"languagesupport(this)\" |
|
||||
onFocus=\"return tGotFocus(this)\" |
|
||||
onChange=\"return onConvert(this)\"></TEXTAREA> |
|
||||
</FONT><br>\n"; |
|
||||
if (($question->{'layout'} eq '4') || ($question->{'layout'} eq '5') || ($question->{'qtyp'} eq 'nrt')) { |
|
||||
$question->{'promptcomments'}=join('',"\ <br>",$question->{'promptcomments'}); |
|
||||
} else { |
|
||||
$question->{'promptcomments'}=join('',"<tr><td>",$question->{'promptcomments'},"</td></tr>"); |
|
||||
} |
|
||||
} |
|
||||
# sac ^ end addition for comment input support |
|
||||
#return; |
|
||||
push @questions, $question; |
|
||||
} |
|
||||
return \@questions; |
|
||||
} |
|
||||
|
|
||||
1 ; # End of library file. |
|
||||
|
|
||||
@ -1,114 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: regcnd.pl,v 1.8 2006/10/19 17:35:29 psims Exp $ |
|
||||
# |
|
||||
# Source File: regcnd.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
if ($FORM{'lang'} eq "") { $FORM{'lang'} = $SESSION{'lang'}; } |
|
||||
if ($FORM{'dbop'} eq 'logout') { |
|
||||
$indextemplate = ($SESSION{'clid'} eq 'std') ? "shome" : "cindex"; |
|
||||
if ($SESSION{'clid'} ne 'std') {&get_client_profile($SESSION{'clid'});} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("$indextemplate"); |
|
||||
} elsif ($FORM{'dbop'} eq 'save') { |
|
||||
$FORM{'uid'} = $SESSION{'uid'}; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
foreach (keys %CANDIDATE) { |
|
||||
if (!( defined($FORM{$_}) )) { |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} |
|
||||
if ($CLIENT{'savechange'} eq "N") { |
|
||||
$FORM{$_} = $CANDIDATE{$_} unless $_ eq 'pwd'; |
|
||||
} |
|
||||
if ($_ eq 'pwd') { |
|
||||
if ($FORM{'oldpwdval'} ne $CANDIDATE{'pwd'} && $FORM{'oldpwdval'} ne '') { |
|
||||
$errmess = "$xlatphrase[888]"; |
|
||||
$direction = "password"; |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} else { |
|
||||
$errmess = "$xlatphrase[879]" unless $FORM{'oldpwdval'} eq ''; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($FORM{'eml'} ne $CANDIDATE{'eml'}) { |
|
||||
$continue_eml_tests = 1; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if ( ($CLIENT{'emlacl'} eq "Y") && ($continue_eml_tests == 1) ){ |
|
||||
my @tempacl = &popEmlAcl($CLIENT{'clid'}); |
|
||||
if ($CLIENT{'emlacllst'} eq "B") { |
|
||||
foreach (@tempacl) { |
|
||||
if ($FORM{'eml'} =~ /$_/g) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($CLIENT{'emlacllst'} eq "W") { |
|
||||
foreach (@tempacl) { |
|
||||
$tempemlacltest .= $_; |
|
||||
} |
|
||||
$tmpemladr = $FORM{'eml'}; |
|
||||
$tmpemladr =~ s/@/ /g; |
|
||||
$tmpemladr =~ /\w+\.\w+$/g; |
|
||||
$tmpemladr = $&; |
|
||||
if ( !($tempemlacltest =~ /$tmpemladr/) ) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ( ($CLIENT{'emlstrict'} eq "Y") && ($continue_eml_tests == 1) ) { |
|
||||
my $clid = $SESSION{'clid'}; |
|
||||
my @cndcols = &get_data("cnd.$SESSION{'clid'}"); |
|
||||
my @duplicates = grep(/$FORM{'eml'}/, @cndcols); |
|
||||
foreach (@duplicates) { |
|
||||
$errmess = $xlatphrase[904]; |
|
||||
$continue_eml_tests = 0; |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
&put_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}, $SESSION{'uac'}); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
#&show_template("regcnd"); |
|
||||
if ($CANDIDATE{'badid'} eq "$xlatphrase[758]") { |
|
||||
#print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} else { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$FORM{'uid'}"; |
|
||||
$vars{'pwd'} = "$FORM{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'badid'} = "$errmess"; |
|
||||
$vars{'direction'} = $direction unless $direction eq ''; |
|
||||
|
|
||||
&redirect("login", \%vars); |
|
||||
} |
|
||||
} elsif ($FORM{'dbop'} eq 'resend') { |
|
||||
if ( $SESSION{'clid'} ) {&get_client_profile($SESSION{'clid'});} ; |
|
||||
&resend_exit_emails($SESSION{'clid'}, $SESSION{'uid'}, $FORM{'tstid'}); |
|
||||
$vars{'tid'} = $SESSION{'tid'}; |
|
||||
$vars{'lang'} = $SESSION{'lang'}; |
|
||||
&redirect("regcnd", \%vars); |
|
||||
} else { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regcnd"); |
|
||||
} |
|
||||
} |
|
||||
@ -1,444 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: regsas.pl,v 1.21 2006/11/28 21:07:48 psims Exp $ |
|
||||
# |
|
||||
# Source File: regsas.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
&setbrowsertype(); |
|
||||
if ($FORM{'newsas'} ne "") { |
|
||||
$SESSION{'clid'} = $FORM{'clid'}; |
|
||||
$SESSION{'lang'} = $FORM{'lang'}; |
|
||||
&get_client_configuration(); |
|
||||
&LanguageSupportInit(); |
|
||||
if ($FORM{'dbop'} eq 'save') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if (&adduidreq($SESSION{'clid'},$FORM{'uidreq'},$FORM{'pwdreq'})) { |
|
||||
$FORM{'uid'}=$FORM{'uidreq'}; |
|
||||
$CANDIDATE{'uid'}=$FORM{'uidreq'}; |
|
||||
$FORM{'clid'}=$SESSION{'clid'}; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}, $opts); |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlsend", "testmanager.com Personal Validation Key", $FORM{'eml'}) unless $CLIENT{'emlval'} ne "Y"; |
|
||||
$FORM{'uac'}='sas'; |
|
||||
&init_session; |
|
||||
&LanguageSupportInit(); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "1"); |
|
||||
$FORM{'notice'} = $SYSTEM{'message'}; |
|
||||
$CANDIDATE{'badid'}=""; |
|
||||
} else { |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}); |
|
||||
if ($FORM{'allowin'} ne "Y") { |
|
||||
$CANDIDATE{'firstlogin'}=""; |
|
||||
$CANDIDATE{'new'}="Y"; |
|
||||
$errmess = $xlatphrase[758]; |
|
||||
$CANDIDATE{'badid'}="$xlatphrase[758]"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
#$CANDIDATE{'sal'}=""; |
|
||||
#$CANDIDATE{'nmf'}=$FORM{'nmf'}; |
|
||||
#$CANDIDATE{'nmm'}=$FORM{'nmm'}; |
|
||||
#$CANDIDATE{'nml'}=$FORM{'nml'}; |
|
||||
#$CANDIDATE{'adr'}=$FORM{'adr'}; |
|
||||
#$CANDIDATE{'cty'}=$FORM{'cty'}; |
|
||||
#$CANDIDATE{'ste'}=$FORM{'ste'}; |
|
||||
#$CANDIDATE{'pst'}=$FORM{'pst'}; |
|
||||
#$CANDIDATE{'ctry'}=$FORM{'ctry'}; |
|
||||
#$CANDIDATE{'eml'}=$FORM{'eml'}; |
|
||||
#$CANDIDATE{'cnd1'}=$FORM{'cnd1'}; |
|
||||
#$CANDIDATE{'cnd2'}=$FORM{'cnd2'}; |
|
||||
#$CANDIDATE{'cnd3'}=$FORM{'cnd3'}; |
|
||||
#$CANDIDATE{'cnd4'}=$FORM{'cnd4'}; |
|
||||
#$CANDIDATE{'uid'}=$FORM{'uid'}; |
|
||||
if ($CANDIDATE{'badid'} eq "$xlatphrase[758]") { |
|
||||
if ($errmess2 ne '') { #This is the fast way to patch error messages |
|
||||
$FORM{'badid'} = $errmess2; |
|
||||
} else { |
|
||||
$FORM{'badid'} = $errmess unless $errmess eq ''; |
|
||||
} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} else { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'newsas'} = ""; |
|
||||
$vars{'dbop'} = "$FORM{'dbop'}"; |
|
||||
|
|
||||
&redirect("login", \%vars); |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
if ($FORM{'lang'} eq "") { $FORM{'lang'} = $SESSION{'lang'}; } |
|
||||
if ($FORM{'dbop'} eq 'logout') { |
|
||||
$indextemplate = ($SESSION{'clid'} eq 'std') ? "shome" : "cindex"; |
|
||||
if ($SESSION{'clid'} ne 'std') {&get_client_profile($SESSION{'clid'});} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("$indextemplate"); |
|
||||
} elsif ($FORM{'dbop'} eq 'save') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
foreach (keys %CANDIDATE) { |
|
||||
if (!( defined($FORM{$_}) )) { |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} |
|
||||
if ($CLIENT{'savechange'} eq "N") { |
|
||||
$FORM{$_} = $CANDIDATE{$_} unless $_ eq 'pwd'; |
|
||||
} |
|
||||
if ($_ eq 'pwd') { #Do this type of check for filters based on seperate buttons |
|
||||
if ($FORM{'oldpwdval'} ne $CANDIDATE{'pwd'} && $FORM{'oldpwdval'} ne '') { |
|
||||
$errmess = "$xlatphrase[888]"; |
|
||||
$direction = "password"; |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} else { |
|
||||
$errmess = "$xlatphrase[879]" unless $FORM{'oldpwdval'} eq ''; |
|
||||
} |
|
||||
} |
|
||||
if ($FORM{'eml'} ne $CANDIDATE{'eml'}) { #Do this type of check on every subsequent filter based revision |
|
||||
$FORM{'validated'} = 'N'; |
|
||||
$continue_eml_tests = 1; |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlsend", "testmanager.com Personal Validation Key", $FORM{'eml'}) unless $CLIENT{'emlval'} ne "Y"; |
|
||||
$CANDIDATE{'badid'}="$xlatphrase[872]" unless $CLIENT{'emlval'} ne "Y"; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if ( ($CLIENT{'emlacl'} eq "Y") && ($continue_eml_tests == 1) ){ |
|
||||
my @tempacl = &popEmlAcl($CLIENT{'clid'}); |
|
||||
if ($CLIENT{'emlacllst'} eq "B") { |
|
||||
foreach (@tempacl) { |
|
||||
if ($FORM{'eml'} =~ /$_/g) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($CLIENT{'emlacllst'} eq "W") { |
|
||||
foreach (@tempacl) { |
|
||||
$tempemlacltest .= $_; |
|
||||
} |
|
||||
$tmpemladr = $FORM{'eml'}; |
|
||||
$tmpemladr =~ s/@/ /g; |
|
||||
$tmpemladr =~ /\w+\.\w+$/g; |
|
||||
$tmpemladr = $&; |
|
||||
if ( !($tempemlacltest =~ /$tmpemladr/) ) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ( ($CLIENT{'emlstrict'} eq "Y") && ($continue_eml_tests == 1) ) { |
|
||||
my $clid = $SESSION{'clid'}; |
|
||||
my @cndcols = &get_data("cnd.$SESSION{'clid'}"); |
|
||||
my @duplicates = grep(/$FORM{'eml'}/, @cndcols); |
|
||||
foreach (@duplicates) { |
|
||||
$errmess = $xlatphrase[904]; |
|
||||
$continue_eml_tests = 0; |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
&put_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
if ($CANDIDATE{'badid'} eq "$xlatphrase[758]" || $CANDIDATE{'badid'} eq "$xlatphrase[872]") { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'badid'} = "$xlatphrase[758]" unless $CANDIDATE{'badid'} ne "$xlatphrase[758]"; |
|
||||
$vars{'badid'} = "$xlatphrase[872]" unless $CANDIDATE{'badid'} ne "$xlatphrase[872]"; |
|
||||
&redirect("login", \%vars); |
|
||||
} else { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'badid'} = $errmess unless $errmess eq ''; |
|
||||
$vars{'direction'} = $direction unless $direction eq ''; |
|
||||
&redirect("login", \%vars); |
|
||||
} |
|
||||
#print "Content-Type: text/html\n\n"; |
|
||||
#&show_template("regsas"); |
|
||||
} elsif ($FORM{'dbop'} eq 'resend') { |
|
||||
&resend_exit_emails($SESSION{'clid'}, $SESSION{'uid'}, $FORM{'tstid'}); |
|
||||
$vars{'tid'} = "$SESSION{'tid'}"; |
|
||||
$vars{'lang'} = "$SESSION{'lang'}"; |
|
||||
&redirect("regsas", \%vars); |
|
||||
} else { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
|
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
my $realkey = &makecndhash($CANDIDATE{'createdate'}, $CANDIDATE{'uid'}); |
|
||||
$realkey =~ s/-//g; |
|
||||
$FORM{'validationcode'} =~ s/-//g; |
|
||||
if ($CLIENT{'emlval'} eq "Y") { #If the client doesnt want selfreg eml validation, ignore this and go straight to regsas. |
|
||||
if ($CANDIDATE{'selfreg'} eq "Y" && $CANDIDATE{'validated'} eq "N") { |
|
||||
if ($FORM{'resendkey'} eq "Y") { |
|
||||
$SESSION{'message'} = "<%=PHRASE.868%>"; |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlresend", "testmanager.com Personal Validation Key", $CANDIDATE{'eml'}); |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("validatesreg"); |
|
||||
} elsif ($FORM{'validationcode'} eq $realkey) { |
|
||||
$FORM{'validated'} = "Y"; |
|
||||
$FORM{'uid'} = $CANDIDATE{'uid'}; #This is because regsas is terribly broken when it treats form variables |
|
||||
&put_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
#&show_template("regsas"); |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
|
|
||||
&redirect("login", \%vars); |
|
||||
} else { |
|
||||
if ($FORM{'validationcode'} ne '') { |
|
||||
$SESSION{'message'} = "<%=PHRASE.867%>"; |
|
||||
} else { |
|
||||
$SESSION{'message'} = "<br>"; |
|
||||
} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("validatesreg"); |
|
||||
} |
|
||||
} elsif ($CANDIDATE{'selfreg'} eq "Y" && $CANDIDATE{'validated'} eq "Y") { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
$FORM{'allowin'} = "Y"; |
|
||||
&show_template("regsas"); |
|
||||
} else { #Dont punish old sreggers without a $CANDIDATE{'validated'} value, which is all of them to this point |
|
||||
$FORM{'allowin'} = "Y"; |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} |
|
||||
} else { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($errmess ne '') { |
|
||||
$FORM{'badid'} = $errmess; |
|
||||
} |
|
||||
&show_template("regsas"); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
# |
|
||||
# Verify that the requested id is not already |
|
||||
# used in admin.dat or cnd.{client} |
|
||||
# if not used add it to the cnd.{client} file |
|
||||
# |
|
||||
sub adduidreq { |
|
||||
my ($clid,$urq,$urpw) = @_; |
|
||||
my @crecs = &get_data("admin.dat"); |
|
||||
my $rec; |
|
||||
my $i; |
|
||||
my $fldkey; |
|
||||
my $fldval; |
|
||||
my $trash; |
|
||||
my @flds; |
|
||||
my $retOK=1; |
|
||||
my @found = grep( /$urq&/ ,@crecs); |
|
||||
if ($#found != -1) { |
|
||||
# |
|
||||
# verify that the first field is the requested urq |
|
||||
# just in case grep picked it up somewhere else in the record |
|
||||
# |
|
||||
foreach $rec (@found) { |
|
||||
@flds=split(/&/, $rec); |
|
||||
if ($flds[0] eq $urq) { |
|
||||
$retOK=0; |
|
||||
$last; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
my $cndeml = $FORM{'eml'}; |
|
||||
if ($CLIENT{'emlacl'} eq "Y") { |
|
||||
my @tempacl = &popEmlAcl($SESSION{'clid'}); |
|
||||
if ($CLIENT{'emlacllst'} eq "B") { |
|
||||
foreach (@tempacl) { |
|
||||
if ($cndeml =~ /$_/g) { |
|
||||
$retOK = 0; |
|
||||
$errmess2 = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($CLIENT{'emlacllst'} eq "W") { |
|
||||
foreach (@tempacl) { |
|
||||
$tempemltest .= $_; |
|
||||
} |
|
||||
$tmpemladr = $cndeml; |
|
||||
$tmpemladr =~ s/@/ /g; |
|
||||
$tmpemladr =~ /\w+\.\w+$/g; |
|
||||
$tmpemladr = $&; #the domain.ltd part of user@domain.ltd |
|
||||
if ( !($tempemltest =~/$tmpemladr/) ) { |
|
||||
$retOK = 0; |
|
||||
$errmess2 = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
if ($CLIENT{'emlstrict'} eq "Y") { |
|
||||
my @cndcols = &get_data("cnd.$clid"); |
|
||||
my @duplicates = grep(/$cndeml/, @cndcols); |
|
||||
foreach (@duplicates) { |
|
||||
$retOK=0; |
|
||||
$errmess2 = $xlatphrase[904]; |
|
||||
} |
|
||||
} |
|
||||
if ($retOK == 1) { |
|
||||
@crecs = &get_data("cnd.$clid"); |
|
||||
my $rhdr = shift @crecs; |
|
||||
@found = grep( /$urq&/ ,@crecs); |
|
||||
if ($#found != -1) { |
|
||||
# |
|
||||
# verify that the first field is the requested uid |
|
||||
# just in case grep picked it up somewhere else in the record |
|
||||
# |
|
||||
foreach $rec (@found) { |
|
||||
@flds=split(/&/, $rec); |
|
||||
if ($flds[0] eq $urq) { |
|
||||
$retOK=0; |
|
||||
$last; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($retOK == 1) { |
|
||||
# |
|
||||
# add the requested uid |
|
||||
# |
|
||||
$rec=$rhdr; |
|
||||
chop($rec); |
|
||||
@flds=split(/&/,$rec); |
|
||||
$rec = join('&',$urq,$urpw); |
|
||||
$FORM{'selfreg'} = "Y"; |
|
||||
for $i (2 .. $#flds) { |
|
||||
$fldkey=$flds[$i]; |
|
||||
$FORM{$fldkey} =~ tr/+/ /; |
|
||||
$fldval=$FORM{$fldkey}; |
|
||||
$rec = join('&', $rec, $fldval); |
|
||||
} |
|
||||
push @crecs,"$rec\n"; |
|
||||
my @csorted = sort @crecs; |
|
||||
@crecs=(); |
|
||||
unshift @csorted,$rhdr; |
|
||||
$retOK=0; |
|
||||
|
|
||||
|
|
||||
#This adds createdate and validated to the new candidate stack |
|
||||
my $shift_hack = shift(@csorted); |
|
||||
$shift_hack =~ (s/authtests/createdate/); |
|
||||
$shift_hack =~ (s/grpid/createdby/); |
|
||||
$_ = $shift_hack; |
|
||||
if ( !(/validated/)) { |
|
||||
chomp $shift_hack; |
|
||||
$shift_hack .= '&validated'."\n"; |
|
||||
} |
|
||||
if ( !(/registrar/)) { |
|
||||
chomp $shift_hack; |
|
||||
$shift_hack .= '®istrar'."\n"; |
|
||||
} |
|
||||
### DED 3/26/07 These fields not yet supported |
|
||||
#if ( !(/cnd3/)) { |
|
||||
#chomp $shift_hack; |
|
||||
#$shift_hack .= '&cnd3'."\n"; |
|
||||
#} |
|
||||
#if ( !(/cnd4/)) { |
|
||||
#chomp $shift_hack; |
|
||||
#$shift_hack .= '&cnd4'."\n"; |
|
||||
#} |
|
||||
unshift (@csorted, $shift_hack); |
|
||||
|
|
||||
my @labels = split('&', @csorted[0]); |
|
||||
my @fields; |
|
||||
foreach (@csorted) { |
|
||||
if (/^$urq&/) { |
|
||||
@fields = split('&', $_); |
|
||||
} |
|
||||
} |
|
||||
my %turbohash = (); #merge them into a hash |
|
||||
foreach (0..$#labels) { |
|
||||
$turbohash{$labels[$_]} = $fields[$_]; |
|
||||
} |
|
||||
$turbohash{'createdate'} = time(); |
|
||||
$turbohash{'createdby'} = $FORM{'uidreq'}; |
|
||||
$turbohash{'validated'} = 'N'; |
|
||||
#Now we have to put them all together in the same order as the key row |
|
||||
my $client_string; #will hold the temp. line for cnd.clientid |
|
||||
foreach (0..$#labels) { |
|
||||
chomp($labels[$_]); #chomp it because $labels[-1] is actually $labels[-1]\n |
|
||||
$client_string .= "&$turbohash{$labels[$_]}"; |
|
||||
} |
|
||||
$client_string =~ s/^&//; |
|
||||
$client_string =~ s/\n//g; |
|
||||
$client_string =~ s/\+/ /g; |
|
||||
$client_string .= "\n"; #insert the \n after the chomp |
|
||||
foreach my $rotator (1..$#csorted) { #scary part where we insert it back into the array |
|
||||
if ($csorted[$rotator] =~ /^$urq&/) { |
|
||||
$csorted[$rotator] = $client_string; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my $tmpfile = join($pathsep, $dataroot, "cnd.$clid"); |
|
||||
my $existed=&file_exists($tmpfile); |
|
||||
if ( open (TMPFILE, ">$tmpfile") ) { |
|
||||
for $i (0 .. $#csorted) { |
|
||||
print TMPFILE "$csorted[$i]"; |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
if ($existed==0) { |
|
||||
$chmodok = chmod 0666, $_[0]; |
|
||||
} |
|
||||
$retOK=1; |
|
||||
} |
|
||||
@csorted=(); |
|
||||
} |
|
||||
} |
|
||||
# |
|
||||
# clean up |
|
||||
# |
|
||||
@flds=(); |
|
||||
@found=(); |
|
||||
@crecs=(); |
|
||||
return $retOK; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
|
|
||||
sub send_the_mail { #This is a special function to send the validation key email. Shouldn't ever be needed outside this file. |
|
||||
my $mmfrom = $CLIENT{'email_from'}; |
|
||||
my $eml_txt = join( $pathsep, $dataroot, $_[0]); |
|
||||
my $mmsubj = $_[1]; |
|
||||
my $mmto = $_[2]; |
|
||||
my $hash_createdate = &get_a_key("cnd.$SESSION{'clid'}", $CANDIDATE{'uid'}, "createdate"); |
|
||||
my $mmbody = ''; |
|
||||
if ( open(EMLBODY, "<$eml_txt") ) { |
|
||||
foreach (<EMLBODY>) { |
|
||||
$mmbody .= $_; |
|
||||
close(EMLBODY); |
|
||||
} |
|
||||
} else { |
|
||||
$mmbody = "Thank you for registering at $ENV{'HTTP_HOST'}. Your personal Registration Code is <%=NOP_valkey%>. You will only have to enter it once.\n" |
|
||||
} |
|
||||
#insert customized regex here |
|
||||
my $valkey = &makecndhash($hash_createdate, $CANDIDATE{'uid'}); |
|
||||
#print STDERR "valkey = $valkey, hash_createdate = $hash_createdate, uid = $CANDIDATE{'uid'}\n"; #uncomment this to see all necessary validation key info |
|
||||
$mmbody =~ s/\<%=NOP_valkey%\>/$valkey/g; |
|
||||
$mmbody = &xlatline($mmbody, '', 0); |
|
||||
|
|
||||
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody); |
|
||||
} |
|
||||
@ -1,462 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: regsas.pl,v 1.21 2006/11/28 21:07:48 psims Exp $ |
|
||||
# |
|
||||
# Source File: regsas.pl |
|
||||
|
|
||||
# Set variables local to this code file. |
|
||||
|
|
||||
# HBI Shorten validation key to less characters. |
|
||||
%Long_Val_Client = () ; |
|
||||
# Inital value, no clients use the long validation string. |
|
||||
# This is a global that could be modified in sitecfg.pl |
|
||||
my $Short_Val_off = 1 ; # Start with the second digit of the computed value. |
|
||||
my $Short_Val_len = 3 ; # Use three characters. |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
&setbrowsertype(); |
|
||||
if ($FORM{'newsas'} ne "") { |
|
||||
$SESSION{'clid'} = $FORM{'clid'}; |
|
||||
$SESSION{'lang'} = $FORM{'lang'}; |
|
||||
&get_client_configuration(); |
|
||||
&LanguageSupportInit(); |
|
||||
if ($FORM{'dbop'} eq 'save') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if (&adduidreq($SESSION{'clid'},$FORM{'uidreq'},$FORM{'pwdreq'})) { |
|
||||
$FORM{'uid'}=$FORM{'uidreq'}; |
|
||||
$CANDIDATE{'uid'}=$FORM{'uidreq'}; |
|
||||
$FORM{'clid'}=$SESSION{'clid'}; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}, $opts); |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlsend", "testmanager.com Personal Validation Key", $FORM{'eml'}) unless $CLIENT{'emlval'} ne "Y"; |
|
||||
$FORM{'uac'}='sas'; |
|
||||
&init_session; |
|
||||
&LanguageSupportInit(); |
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "1"); |
|
||||
$FORM{'notice'} = $SYSTEM{'message'}; |
|
||||
$CANDIDATE{'badid'}=""; |
|
||||
} else { |
|
||||
&get_candidate_profile($SESSION{'clid'}, $FORM{'uid'}); |
|
||||
if ($FORM{'allowin'} ne "Y") { |
|
||||
$CANDIDATE{'firstlogin'}=""; |
|
||||
$CANDIDATE{'new'}="Y"; |
|
||||
$errmess = $xlatphrase[758]; |
|
||||
$CANDIDATE{'badid'}="$xlatphrase[758]"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
#$CANDIDATE{'sal'}=""; |
|
||||
#$CANDIDATE{'nmf'}=$FORM{'nmf'}; |
|
||||
#$CANDIDATE{'nmm'}=$FORM{'nmm'}; |
|
||||
#$CANDIDATE{'nml'}=$FORM{'nml'}; |
|
||||
#$CANDIDATE{'adr'}=$FORM{'adr'}; |
|
||||
#$CANDIDATE{'cty'}=$FORM{'cty'}; |
|
||||
#$CANDIDATE{'ste'}=$FORM{'ste'}; |
|
||||
#$CANDIDATE{'pst'}=$FORM{'pst'}; |
|
||||
#$CANDIDATE{'ctry'}=$FORM{'ctry'}; |
|
||||
#$CANDIDATE{'eml'}=$FORM{'eml'}; |
|
||||
#$CANDIDATE{'cnd1'}=$FORM{'cnd1'}; |
|
||||
#$CANDIDATE{'cnd2'}=$FORM{'cnd2'}; |
|
||||
#$CANDIDATE{'cnd3'}=$FORM{'cnd3'}; |
|
||||
#$CANDIDATE{'cnd4'}=$FORM{'cnd4'}; |
|
||||
#$CANDIDATE{'uid'}=$FORM{'uid'}; |
|
||||
if ($CANDIDATE{'badid'} eq "$xlatphrase[758]") { |
|
||||
if ($errmess2 ne '') { #This is the fast way to patch error messages |
|
||||
$FORM{'badid'} = $errmess2; |
|
||||
} else { |
|
||||
$FORM{'badid'} = $errmess unless $errmess eq ''; |
|
||||
} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} else { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'newsas'} = ""; |
|
||||
$vars{'dbop'} = "$FORM{'dbop'}"; |
|
||||
|
|
||||
&redirect("login", \%vars); |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
if ($FORM{'lang'} eq "") { $FORM{'lang'} = $SESSION{'lang'}; } |
|
||||
if ($FORM{'dbop'} eq 'logout') { |
|
||||
$indextemplate = ($SESSION{'clid'} eq 'std') ? "shome" : "cindex"; |
|
||||
if ($SESSION{'clid'} ne 'std') {&get_client_profile($SESSION{'clid'});} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("$indextemplate"); |
|
||||
} elsif ($FORM{'dbop'} eq 'save') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
foreach (keys %CANDIDATE) { |
|
||||
if (!( defined($FORM{$_}) )) { |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} |
|
||||
if ($CLIENT{'savechange'} eq "N") { |
|
||||
$FORM{$_} = $CANDIDATE{$_} unless $_ eq 'pwd'; |
|
||||
} |
|
||||
if ($_ eq 'pwd') { #Do this type of check for filters based on seperate buttons |
|
||||
if ($FORM{'oldpwdval'} ne $CANDIDATE{'pwd'} && $FORM{'oldpwdval'} ne '') { |
|
||||
$errmess = "$xlatphrase[888]"; |
|
||||
$direction = "password"; |
|
||||
$FORM{$_} = $CANDIDATE{$_}; |
|
||||
} else { |
|
||||
$errmess = "$xlatphrase[879]" unless $FORM{'oldpwdval'} eq ''; |
|
||||
} |
|
||||
} |
|
||||
if ($FORM{'eml'} ne $CANDIDATE{'eml'}) { #Do this type of check on every subsequent filter based revision |
|
||||
$FORM{'validated'} = 'N'; |
|
||||
$continue_eml_tests = 1; |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlsend", "testmanager.com Personal Validation Key", $FORM{'eml'}) unless $CLIENT{'emlval'} ne "Y"; |
|
||||
$CANDIDATE{'badid'}="$xlatphrase[872]" unless $CLIENT{'emlval'} ne "Y"; |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if ( ($CLIENT{'emlacl'} eq "Y") && ($continue_eml_tests == 1) ){ |
|
||||
my @tempacl = &popEmlAcl($CLIENT{'clid'}); |
|
||||
if ($CLIENT{'emlacllst'} eq "B") { |
|
||||
foreach (@tempacl) { |
|
||||
if ($FORM{'eml'} =~ /$_/g) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($CLIENT{'emlacllst'} eq "W") { |
|
||||
foreach (@tempacl) { |
|
||||
$tempemlacltest .= $_; |
|
||||
} |
|
||||
$tmpemladr = $FORM{'eml'}; |
|
||||
$tmpemladr =~ s/@/ /g; |
|
||||
$tmpemladr =~ /\w+\.\w+$/g; |
|
||||
$tmpemladr = $&; |
|
||||
if ( !($tempemlacltest =~ /$tmpemladr/) ) { |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
$continue_eml_tests = 0; |
|
||||
$errmess = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ( ($CLIENT{'emlstrict'} eq "Y") && ($continue_eml_tests == 1) ) { |
|
||||
my $clid = $SESSION{'clid'}; |
|
||||
my @cndcols = &get_data("cnd.$SESSION{'clid'}"); |
|
||||
my @duplicates = grep(/$FORM{'eml'}/, @cndcols); |
|
||||
foreach (@duplicates) { |
|
||||
$errmess = $xlatphrase[904]; |
|
||||
$continue_eml_tests = 0; |
|
||||
$FORM{'eml'} = $CANDIDATE{'eml'}; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
&put_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
if ($CANDIDATE{'badid'} eq "$xlatphrase[758]" || $CANDIDATE{'badid'} eq "$xlatphrase[872]") { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'badid'} = "$xlatphrase[758]" unless $CANDIDATE{'badid'} ne "$xlatphrase[758]"; |
|
||||
$vars{'badid'} = "$xlatphrase[872]" unless $CANDIDATE{'badid'} ne "$xlatphrase[872]"; |
|
||||
&redirect("login", \%vars); |
|
||||
} else { |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
$vars{'badid'} = $errmess unless $errmess eq ''; |
|
||||
$vars{'direction'} = $direction unless $direction eq ''; |
|
||||
&redirect("login", \%vars); |
|
||||
} |
|
||||
#print "Content-Type: text/html\n\n"; |
|
||||
#&show_template("regsas"); |
|
||||
} elsif ($FORM{'dbop'} eq 'resend') { |
|
||||
&resend_exit_emails($SESSION{'clid'}, $SESSION{'uid'}, $FORM{'tstid'}); |
|
||||
$vars{'tid'} = "$SESSION{'tid'}"; |
|
||||
$vars{'lang'} = "$SESSION{'lang'}"; |
|
||||
&redirect("regsas", \%vars); |
|
||||
} else { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
|
|
||||
my $opts = { restrict_to_availability_window => 1 }; |
|
||||
&get_candidate_profile( $SESSION{'clid'}, $SESSION{'uid'}, $opts); |
|
||||
my $realkey = &makecndhash($CANDIDATE{'createdate'}, $CANDIDATE{'uid'}); |
|
||||
$realkey =~ s/-//g; |
|
||||
# HBI Shorten validation key to less characters. |
|
||||
unless ($Long_Val_Client{$SESSION{'clid'}} ) { |
|
||||
$realkey = substr($realkey, $Short_Val_off, $Short_Val_len) ; |
|
||||
} |
|
||||
$FORM{'validationcode'} =~ s/-//g; |
|
||||
if ($CLIENT{'emlval'} eq "Y") { #If the client doesnt want selfreg eml validation, ignore this and go straight to regsas. |
|
||||
if ($CANDIDATE{'selfreg'} eq "Y" && $CANDIDATE{'validated'} eq "N") { |
|
||||
if ($FORM{'resendkey'} eq "Y") { |
|
||||
$SESSION{'message'} = "<%=PHRASE.868%>"; |
|
||||
&send_the_mail("$CLIENT{'clid'}.emlresend", "testmanager.com Personal Validation Key", $CANDIDATE{'eml'}); |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("validatesreg"); |
|
||||
} elsif ($FORM{'validationcode'} eq $realkey) { |
|
||||
$FORM{'validated'} = "Y"; |
|
||||
$FORM{'uid'} = $CANDIDATE{'uid'}; #This is because regsas is terribly broken when it treats form variables |
|
||||
&put_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
#&show_template("regsas"); |
|
||||
$vars{'home'} = "client"; |
|
||||
$vars{'lang'} = "$FORM{'lang'}"; |
|
||||
$vars{'uid'} = "$CANDIDATE{'uid'}"; |
|
||||
$vars{'pwd'} = "$CANDIDATE{'pwd'}"; |
|
||||
$vars{'clid'} = "$SESSION{'clid'}"; |
|
||||
$vars{'cnd'} = "Login"; |
|
||||
|
|
||||
&redirect("login", \%vars); |
|
||||
} else { |
|
||||
if ($FORM{'validationcode'} ne '') { |
|
||||
$SESSION{'message'} = "<%=PHRASE.867%>"; |
|
||||
} else { |
|
||||
$SESSION{'message'} = "<br>"; |
|
||||
} |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("validatesreg"); |
|
||||
} |
|
||||
} elsif ($CANDIDATE{'selfreg'} eq "Y" && $CANDIDATE{'validated'} eq "Y") { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
$FORM{'allowin'} = "Y"; |
|
||||
&show_template("regsas"); |
|
||||
} else { #Dont punish old sreggers without a $CANDIDATE{'validated'} value, which is all of them to this point |
|
||||
$FORM{'allowin'} = "Y"; |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
&show_template("regsas"); |
|
||||
} |
|
||||
} else { |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if ($errmess ne '') { |
|
||||
$FORM{'badid'} = $errmess; |
|
||||
} |
|
||||
&show_template("regsas"); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
# |
|
||||
# Verify that the requested id is not already |
|
||||
# used in admin.dat or cnd.{client} |
|
||||
# if not used add it to the cnd.{client} file |
|
||||
# |
|
||||
sub adduidreq { |
|
||||
my ($clid,$urq,$urpw) = @_; |
|
||||
my @crecs = &get_data("admin.dat"); |
|
||||
my $rec; |
|
||||
my $i; |
|
||||
my $fldkey; |
|
||||
my $fldval; |
|
||||
my $trash; |
|
||||
my @flds; |
|
||||
my $retOK=1; |
|
||||
my @found = grep( /$urq&/ ,@crecs); |
|
||||
if ($#found != -1) { |
|
||||
# |
|
||||
# verify that the first field is the requested urq |
|
||||
# just in case grep picked it up somewhere else in the record |
|
||||
# |
|
||||
foreach $rec (@found) { |
|
||||
@flds=split(/&/, $rec); |
|
||||
if ($flds[0] eq $urq) { |
|
||||
$retOK=0; |
|
||||
$last; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
my $cndeml = $FORM{'eml'}; |
|
||||
if ($CLIENT{'emlacl'} eq "Y") { |
|
||||
my @tempacl = &popEmlAcl($SESSION{'clid'}); |
|
||||
if ($CLIENT{'emlacllst'} eq "B") { |
|
||||
foreach (@tempacl) { |
|
||||
if ($cndeml =~ /$_/g) { |
|
||||
$retOK = 0; |
|
||||
$errmess2 = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($CLIENT{'emlacllst'} eq "W") { |
|
||||
foreach (@tempacl) { |
|
||||
$tempemltest .= $_; |
|
||||
} |
|
||||
$tmpemladr = $cndeml; |
|
||||
$tmpemladr =~ s/@/ /g; |
|
||||
$tmpemladr =~ /\w+\.\w+$/g; |
|
||||
$tmpemladr = $&; #the domain.ltd part of user@domain.ltd |
|
||||
if ( !($tempemltest =~/$tmpemladr/) ) { |
|
||||
$retOK = 0; |
|
||||
$errmess2 = $xlatphrase[903]; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
if ($CLIENT{'emlstrict'} eq "Y") { |
|
||||
my @cndcols = &get_data("cnd.$clid"); |
|
||||
my @duplicates = grep(/$cndeml/, @cndcols); |
|
||||
foreach (@duplicates) { |
|
||||
$retOK=0; |
|
||||
$errmess2 = $xlatphrase[904]; |
|
||||
} |
|
||||
} |
|
||||
if ($retOK == 1) { |
|
||||
@crecs = &get_data("cnd.$clid"); |
|
||||
my $rhdr = shift @crecs; |
|
||||
@found = grep( /$urq&/ ,@crecs); |
|
||||
if ($#found != -1) { |
|
||||
# |
|
||||
# verify that the first field is the requested uid |
|
||||
# just in case grep picked it up somewhere else in the record |
|
||||
# |
|
||||
foreach $rec (@found) { |
|
||||
@flds=split(/&/, $rec); |
|
||||
if ($flds[0] eq $urq) { |
|
||||
$retOK=0; |
|
||||
$last; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($retOK == 1) { |
|
||||
# |
|
||||
# add the requested uid |
|
||||
# |
|
||||
$rec=$rhdr; |
|
||||
chop($rec); |
|
||||
@flds=split(/&/,$rec); |
|
||||
$rec = join('&',$urq,$urpw); |
|
||||
$FORM{'selfreg'} = "Y"; |
|
||||
for $i (2 .. $#flds) { |
|
||||
$fldkey=$flds[$i]; |
|
||||
$FORM{$fldkey} =~ tr/+/ /; |
|
||||
$fldval=$FORM{$fldkey}; |
|
||||
$rec = join('&', $rec, $fldval); |
|
||||
} |
|
||||
push @crecs,"$rec\n"; |
|
||||
my @csorted = sort @crecs; |
|
||||
@crecs=(); |
|
||||
unshift @csorted,$rhdr; |
|
||||
$retOK=0; |
|
||||
|
|
||||
|
|
||||
#This adds createdate and validated to the new candidate stack |
|
||||
my $shift_hack = shift(@csorted); |
|
||||
$shift_hack =~ (s/authtests/createdate/); |
|
||||
$shift_hack =~ (s/grpid/createdby/); |
|
||||
$_ = $shift_hack; |
|
||||
if ( !(/validated/)) { |
|
||||
chomp $shift_hack; |
|
||||
$shift_hack .= '&validated'."\n"; |
|
||||
} |
|
||||
if ( !(/registrar/)) { |
|
||||
chomp $shift_hack; |
|
||||
$shift_hack .= '®istrar'."\n"; |
|
||||
} |
|
||||
### DED 3/26/07 These fields not yet supported |
|
||||
#if ( !(/cnd3/)) { |
|
||||
#chomp $shift_hack; |
|
||||
#$shift_hack .= '&cnd3'."\n"; |
|
||||
#} |
|
||||
#if ( !(/cnd4/)) { |
|
||||
#chomp $shift_hack; |
|
||||
#$shift_hack .= '&cnd4'."\n"; |
|
||||
#} |
|
||||
unshift (@csorted, $shift_hack); |
|
||||
|
|
||||
my @labels = split('&', @csorted[0]); |
|
||||
my @fields; |
|
||||
foreach (@csorted) { |
|
||||
if (/^$urq&/) { |
|
||||
@fields = split('&', $_); |
|
||||
} |
|
||||
} |
|
||||
my %turbohash = (); #merge them into a hash |
|
||||
foreach (0..$#labels) { |
|
||||
$turbohash{$labels[$_]} = $fields[$_]; |
|
||||
} |
|
||||
$turbohash{'createdate'} = time(); |
|
||||
$turbohash{'createdby'} = $FORM{'uidreq'}; |
|
||||
$turbohash{'validated'} = 'N'; |
|
||||
#Now we have to put them all together in the same order as the key row |
|
||||
my $client_string; #will hold the temp. line for cnd.clientid |
|
||||
foreach (0..$#labels) { |
|
||||
chomp($labels[$_]); #chomp it because $labels[-1] is actually $labels[-1]\n |
|
||||
$client_string .= "&$turbohash{$labels[$_]}"; |
|
||||
} |
|
||||
$client_string =~ s/^&//; |
|
||||
$client_string =~ s/\n//g; |
|
||||
$client_string =~ s/\+/ /g; |
|
||||
$client_string .= "\n"; #insert the \n after the chomp |
|
||||
foreach my $rotator (1..$#csorted) { #scary part where we insert it back into the array |
|
||||
if ($csorted[$rotator] =~ /^$urq&/) { |
|
||||
$csorted[$rotator] = $client_string; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my $tmpfile = join($pathsep, $dataroot, "cnd.$clid"); |
|
||||
my $existed=&file_exists($tmpfile); |
|
||||
if ( open (TMPFILE, ">$tmpfile") ) { |
|
||||
for $i (0 .. $#csorted) { |
|
||||
print TMPFILE "$csorted[$i]"; |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
if ($existed==0) { |
|
||||
$chmodok = chmod 0666, $_[0]; |
|
||||
} |
|
||||
$retOK=1; |
|
||||
} |
|
||||
@csorted=(); |
|
||||
} |
|
||||
} |
|
||||
# |
|
||||
# clean up |
|
||||
# |
|
||||
@flds=(); |
|
||||
@found=(); |
|
||||
@crecs=(); |
|
||||
return $retOK; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
|
|
||||
sub send_the_mail { #This is a special function to send the validation key email. Shouldn't ever be needed outside this file. |
|
||||
my $mmfrom = $CLIENT{'email_from'}; |
|
||||
my $eml_txt = join( $pathsep, $dataroot, $_[0]); |
|
||||
my $mmsubj = $_[1]; |
|
||||
my $mmto = $_[2]; |
|
||||
my $hash_createdate = &get_a_key("cnd.$SESSION{'clid'}", $CANDIDATE{'uid'}, "createdate"); |
|
||||
my $mmbody = ''; |
|
||||
if ( open(EMLBODY, "<$eml_txt") ) { |
|
||||
foreach (<EMLBODY>) { |
|
||||
$mmbody .= $_; |
|
||||
close(EMLBODY); |
|
||||
} |
|
||||
} else { |
|
||||
$mmbody = "Thank you for registering at $ENV{'HTTP_HOST'}. Your personal Registration Code is <%=NOP_valkey%>. You will only have to enter it once.\n" |
|
||||
} |
|
||||
#insert customized regex here |
|
||||
my $valkey = &makecndhash($hash_createdate, $CANDIDATE{'uid'}); |
|
||||
#print STDERR "valkey = $valkey, hash_createdate = $hash_createdate, uid = $CANDIDATE{'uid'}\n"; #uncomment this to see all necessary validation key info |
|
||||
# HBI Shorten validation key to less characters. |
|
||||
unless ($Long_Val_Client{$SESSION{'clid'}} ) { |
|
||||
$valkey =~ s/-//g; |
|
||||
$valkey = substr($valkey, $Short_Val_off, $Short_Val_len) ; |
|
||||
} |
|
||||
$mmbody =~ s/\<%=NOP_valkey%\>/$valkey/g; |
|
||||
$mmbody = &xlatline($mmbody, '', 0); |
|
||||
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody); |
|
||||
} |
|
||||
|
|
||||
@ -1,468 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: sadmin.pl,v 1.12 2006/11/28 21:07:48 psims Exp $ |
|
||||
# |
|
||||
# Source File: sadmin.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
if ($SESSION{'clid'} ne 'std') { |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
if ($SESSION{'uac'} eq 'admin' || $SESSION{'uac'} eq 'madmin') { |
|
||||
$FORM{'pageid'} = "Group"; |
|
||||
$FORM{'PAGEID'} = "GROUP"; |
|
||||
$mainttmplt = "frgrpadmin"; |
|
||||
} else { |
|
||||
&get_candidate_profile($SESSION{'clid'}, $SESSION{'uid'}); |
|
||||
$FORM{'pageid'} = "Gradebook"; |
|
||||
$FORM{'PAGEID'} = "GRADEBOOK"; |
|
||||
$mainttmplt = "frgradebooks"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
my @tempacl = &popEmlAcl($SESSION{'clid'}); |
|
||||
foreach (@tempacl) { |
|
||||
$CLIENT{'emlaclstr'} .= "$_,"; |
|
||||
} |
|
||||
$CLIENT{'emlaclstr'} =~ s/@//g; |
|
||||
$CLIENT{'emlaclstr'} =~ s/,$//g; |
|
||||
|
|
||||
|
|
||||
|
|
||||
if ($FORM{'idx'} eq '1') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/I"); |
|
||||
if ($SESSION{'uac'} eq 'admin' || $SESSION{'uac'} eq 'gadmin' || $SESSION{'uac'} eq 'madmin') { |
|
||||
&show_template("sadminidx"); |
|
||||
} else { |
|
||||
&show_template("cndidx"); |
|
||||
} |
|
||||
} elsif ($FORM{'dtl'} eq '0') { |
|
||||
print "<HTML>\n$xlatphrase[539]<BR>$xlatphrase[540]</HTML>\n"; |
|
||||
} elsif ($FORM{'dtl'} eq '1') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/CM"); |
|
||||
if ($SESSION{'uac'} eq 'gadmin') { |
|
||||
&show_admin_request("maintclient"); |
|
||||
} else { |
|
||||
$FORM{'dbop'} = 'ccupd'; |
|
||||
&show_admin_request("cdef"); |
|
||||
} |
|
||||
} elsif ($FORM{'dtl'} eq '12') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/TR"); |
|
||||
&show_admin_request("treplicaframe"); |
|
||||
} elsif ($FORM{'dtl'} eq '13') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/TO"); |
|
||||
&show_admin_request("tocrinpframe"); |
|
||||
} elsif ($FORM{'dtl'} eq '2') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/TM"); |
|
||||
$TEST{'id'} = $FORM{'tstid'}; |
|
||||
&show_admin_request("tdefframe"); |
|
||||
} elsif ($FORM{'dtl'} eq '21') { |
|
||||
if ($SESSION{'uac'} eq 'cnd') { |
|
||||
$CANDIDATE{'ownedtests'} = &get_group_tests($SESSION{'clid'}, $SESSION{'uid'}, 0); |
|
||||
} |
|
||||
&show_admin_request("mainttest"); |
|
||||
} elsif ($FORM{'dtl'} eq '99') { |
|
||||
&show_template("selectpg"); |
|
||||
} elsif ($FORM{'dtl'} eq '3') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/R"); |
|
||||
&show_admin_request("maintreport"); |
|
||||
} elsif ($FORM{'dtl'} eq '4') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/DL"); |
|
||||
&show_admin_downloads; |
|
||||
} elsif ($FORM{'dtl'} eq '5') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/DB"); |
|
||||
&show_admin_request("maintdb"); |
|
||||
} elsif ($FORM{'dtl'} eq '6') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/CF"); |
|
||||
# set FORM.colors |
|
||||
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}"); |
|
||||
$omsg = ""; |
|
||||
open( CFGFILE, "<$trash" ) or $omsg="not found"; |
|
||||
if ($omsg eq 'not found') { |
|
||||
$trash = join( $pathsep, $dataroot, "config.std"); |
|
||||
open( CFGFILE, "<$trash" ) or return; |
|
||||
} |
|
||||
@cfgentries = <CFGFILE>; |
|
||||
close CFGFILE; |
|
||||
$langdef = "enu"; |
|
||||
$FORM{'colors'} = ""; |
|
||||
for (0 .. $#cfgentries) { |
|
||||
chop ($cfgentries[$_]); |
|
||||
($entrykey,$entryvalue) = split(/=/, $cfgentries[$_]); |
|
||||
if ($entrykey eq 'DEFAULTLANG') { |
|
||||
$langdef = $entryvalue; |
|
||||
$langselfr = ($langdef eq 'fr') ? " SELECTED" : ""; |
|
||||
$langselsp = ($langdef eq 'sp') ? " SELECTED" : ""; |
|
||||
$langseldeu = ($langdef eq 'deu') ? " SELECTED" : ""; |
|
||||
$langselenu = ($langdef eq 'enu') ? " SELECTED" : ""; |
|
||||
$langselena = ($langdef eq 'ena') ? " SELECTED" : ""; |
|
||||
$langseleuv = ($langdef eq 'euv') ? " SELECTED" : ""; |
|
||||
$langselcyr = ($langdef eq 'cyr') ? " SELECTED" : ""; |
|
||||
$langselmy = ($langdef eq 'my') ? " SELECTED" : ""; |
|
||||
$langselkor = ($langdef eq 'kor') ? " SELECTED" : ""; |
|
||||
$langselafr = ($langdef eq 'afr') ? " SELECTED" : ""; |
|
||||
$langselhin = ($langdef eq 'hin') ? " SELECTED" : ""; |
|
||||
$colortag = "<TR> |
|
||||
<TD align=right> |
|
||||
$xlatphrase[541]\ \; |
|
||||
</TD> |
|
||||
<TD align=left> |
|
||||
<SELECT NAME=\"CDEFAULTLANG\" onChange=\"reset_autotimer()\"> |
|
||||
<OPTION VALUE=\"enu\"$langselenu>$LANGUAGE_ID{'enu'} |
|
||||
<OPTION VALUE=\"ena\"$langselena>$LANGUAGE_ID{'ena'} |
|
||||
<OPTION VALUE=\"euv\"$langseleuv>$LANGUAGE_ID{'euv'} |
|
||||
<OPTION VALUE=\"fr\"$langselfr>Fráncáís ($LANGUAGE_ID{'fr'}) |
|
||||
<OPTION VALUE=\"deu\"$langseldeu>Dëutsch ($LANGUAGE_ID{'deu'}) |
|
||||
<OPTION VALUE=\"sp\"$langselsp>Español ($LANGUAGE_ID{'sp'}) |
|
||||
<OPTION VALUE=\"cyr\"$langselcyr>Cyrillic ($LANGUAGE_ID{'cyr'}) |
|
||||
<OPTION VALUE=\"my\"$langselmy>Malay ($LANGUAGE_ID{'my'}) |
|
||||
<OPTION VALUE=\"kor\"$langselkor>Korean ($LANGUAGE_ID{'kor'}) |
|
||||
<OPTION VALUE=\"afr\"$langselafr>Afrikaans ($LANGUAGE_ID{'afr'}) |
|
||||
<OPTION VALUE=\"hin\"$langselafr>Hindi ($LANGUAGE_ID{'hin'}) |
|
||||
</SELECT> |
|
||||
</TD> |
|
||||
</TR>\n"; |
|
||||
$FORM{'language'} = join('', $colortag, $FORM{'language'}); |
|
||||
} elsif ($entrykey eq 'IP_ACCESS_FILTER') { |
|
||||
$FORM{'language'} = " <TR> |
|
||||
<TD align=right width=50\%> |
|
||||
$xlatphrase[385]\ \; |
|
||||
</TD> |
|
||||
<TD align=left width=50\%> |
|
||||
<INPUT TYPE=TEXT NAME=\"C$entrykey\" VALUE=\"$entryvalue\" onChange=\"reset_autotimer()\"> |
|
||||
</TD> |
|
||||
</TR>\n"; |
|
||||
} else { |
|
||||
if ($entrykey eq 'BACKGROUND') { |
|
||||
$colortag = " <TR> |
|
||||
<TD align=right><font size=1>$entrykey:\ \;</font></TD> |
|
||||
<TD align=left><INPUT TYPE=FILE NAME=\"C$entrykey\" VALUE=\"$entryvalue\" onChange=\"reset_autotimer()\"></TD> |
|
||||
</TR>\n"; |
|
||||
} else { |
|
||||
if (($entrykey =~ /COLOR/) |
|
||||
|| ($entrykey =~ 'LINK') |
|
||||
|| ($entrykey =~ 'ALINK') |
|
||||
|| ($entrykey =~ 'VLINK') |
|
||||
|| ($entrykey eq 'TEXT') ) { |
|
||||
$gotfocus = "onFocus=\"return tGotFocus(this)\""; |
|
||||
} else { |
|
||||
$gotfocus = ""; |
|
||||
} |
|
||||
$colortag = " <TR> |
|
||||
<TD align=right nowrap><font size=1>$entrykey:\ \;</font></TD> |
|
||||
<TD align=left><INPUT TYPE=TEXT NAME=\"C$entrykey\" SIZE=8 MAXLENGTH=7 VALUE=\"$entryvalue\" $gotfocus onChange=\"reset_autotimer()\"></TD> |
|
||||
</TR>\n"; |
|
||||
} |
|
||||
$FORM{'colors'} = join('', $FORM{'colors'}, $colortag); |
|
||||
} |
|
||||
} |
|
||||
&show_admin_request("maintcfg"); |
|
||||
} elsif ($FORM{'dtl'} eq '7') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/GP"); |
|
||||
&show_admin_request($mainttmplt); |
|
||||
} elsif ($FORM{'dtl'} eq '8') { |
|
||||
#Begin filtering |
|
||||
$filterbydate = $FORM{'filterbydate'}; |
|
||||
$day_filter = $FORM{'day_filter'}; |
|
||||
$date_filter = $FORM{'date_filter'}; |
|
||||
$cnd1_filter = $FORM{'cnd1'}; |
|
||||
$cnd2_filter = $FORM{'cnd2'}; |
|
||||
$cnd3_filter = $FORM{'cnd3'}; |
|
||||
$cnd4_filter = $FORM{'cnd4'}; |
|
||||
#End filtering |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/CC"); |
|
||||
&show_admin_request("maintcnd"); |
|
||||
} elsif ($FORM{'dtl'} eq '9') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/RG"); |
|
||||
&show_admin_request("regcnd"); |
|
||||
} elsif ($FORM{'dtl'} eq '10') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/IM"); |
|
||||
&show_admin_request("upimport"); |
|
||||
} elsif ($FORM{'dtl'} eq '11') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "SA/LC"); |
|
||||
&show_admin_request("frlicadmin"); |
|
||||
} elsif ($FORM{'dbop'} ne '') { |
|
||||
&show_dbop_response; |
|
||||
} else { |
|
||||
&show_illegal_access_warning; |
|
||||
} |
|
||||
} else { |
|
||||
&logger::logerr("Unable to get session with &get_session($FORM{'tid'})"); |
|
||||
&show_illegal_access_warning; |
|
||||
} |
|
||||
|
|
||||
sub show_license_request { |
|
||||
} |
|
||||
|
|
||||
sub show_admin_downloads { |
|
||||
@dlrecs = &get_data("downloads.dat"); |
|
||||
$bFirst=1; |
|
||||
if ($#dlrecs eq 0) { |
|
||||
$download = "<OPTION VALUE=\"nya\">No downloads are currently available.\n"; |
|
||||
$SYSTEM{'downloadcount'} = 1; |
|
||||
} else { |
|
||||
$downloadcount=0; |
|
||||
foreach $dlrec (@dlrecs) { |
|
||||
$msg = ""; |
|
||||
if ($bFirst) { |
|
||||
$bFirst = 0; |
|
||||
} else { |
|
||||
chop ($dlrec); |
|
||||
@flds = split(/&/, $dlrec); |
|
||||
$dlfile = join($pathsep, $pubroot, "downloads/$flds[2]"); |
|
||||
open (TMPFILE, "<$dlfile") or $msg="nya"; |
|
||||
if ($msg eq 'nya') { |
|
||||
$download = "<OPTION VALUE=\"nya\">$flds[1] (Coming Soon)\n"; |
|
||||
} else { |
|
||||
binmode(TMPFILE); |
|
||||
$fsize = (stat(TMPFILE))[7]; |
|
||||
close TMPFILE; |
|
||||
$download = "<OPTION VALUE=\"$flds[2]\">$flds[1] ($fsize bytes)\n"; |
|
||||
} |
|
||||
$downloadcount++; |
|
||||
$downloads = join('', $downloads , $download); |
|
||||
} |
|
||||
} |
|
||||
if ($downloadcount == 0) { $downloadcount = 1;} |
|
||||
if ($downloadcount > 10) { $downloadcount = 10;}; |
|
||||
$SYSTEM{'downloadcount'} = $downloadcount; |
|
||||
} |
|
||||
$SYSTEM{'downloads'} = $downloads; |
|
||||
@dlrecs = (); |
|
||||
$downloads = ""; |
|
||||
$download = ""; |
|
||||
&show_template("download"); |
|
||||
} |
|
||||
|
|
||||
#sub show_admin_request { ##moved to smilib |
|
||||
# my ($key) = @_; |
|
||||
# &get_template($key); |
|
||||
# @lines = &get_template($key); |
|
||||
# foreach $line (@lines) { |
|
||||
# $line = &xlatline($line); |
|
||||
# } |
|
||||
#} |
|
||||
|
|
||||
sub show_dbop_response { |
|
||||
if ($FORM{'dbop'} eq 'tnew') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Define New Test"); |
|
||||
$FORM{'newtest'} = "Y"; |
|
||||
@lines = &get_template("tdefframe"); |
|
||||
&print_response; |
|
||||
} elsif ($FORM{'dbop'} eq'tdel') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Delete Test $FORM{'tstid'}"); |
|
||||
@trecs = &get_test_list($SESSION{'clid'}); |
|
||||
foreach $trec (@trecs) { |
|
||||
chop ($trec); |
|
||||
($id, $trash) = split(/\&/, $trec); |
|
||||
if ($FORM{'tstid'} ne $id) { |
|
||||
push @newtests, $trec; |
|
||||
} |
|
||||
} |
|
||||
@trecs = @newtests; |
|
||||
&save_test_list($SESSION{'clid'}); |
|
||||
$showmessage = "Test $FORM{'tstid'} has been deleted."; |
|
||||
&show_message_with_close($showmessage); |
|
||||
} elsif ($FORM{'dbop'} eq 'tupd') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Edit Test $FORM{'tstid'}"); |
|
||||
$TEST{'new'} = "N"; |
|
||||
&get_test_profile($SESSION{'clid'}, $FORM{'tstid'}); |
|
||||
@lines = &get_template("tdefframe"); |
|
||||
&print_response; |
|
||||
} elsif ($FORM{'dbop'} eq 'cnew') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "New Client"); |
|
||||
$FORM{'newclient'} = "Y"; |
|
||||
@lines = &get_template("cdef"); |
|
||||
&print_response; |
|
||||
} elsif ($FORM{'dbop'} eq 'cdel') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Delete Client $FORM{'clid'}"); |
|
||||
&open_results; |
|
||||
&client_delete_response; |
|
||||
&close_results; |
|
||||
$FORM{'dtl'} eq 8; |
|
||||
} elsif ($FORM{'dbop'} eq 'cupd') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Edit Client $FORM{'clid'}"); |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
@lines = &get_template("cdef"); |
|
||||
&print_response; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub print_response { |
|
||||
foreach $line (@lines) { |
|
||||
$srch = "<%=CLIENT.REPORTING%>"; |
|
||||
if ( $line =~ /$srch/i) { |
|
||||
&client_reporting_options($CLIENT{'clid'}); |
|
||||
} else { |
|
||||
$line = &xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub client_reporting_options { |
|
||||
# @rrecs = &get_test_list($_[0]); |
|
||||
} |
|
||||
|
|
||||
sub client_delete_response { |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
|
|
||||
print "Deleting $FORM{'clid'} $CLIENT{'clnmc'} ...<BR>\n"; |
|
||||
|
|
||||
# open preservation file |
|
||||
$archivefile = join($pathsep, $dataroot, "$FORM{'clid'}.dat"); |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
open (ARCHFILE, ">$archivefile"); |
|
||||
|
|
||||
# delete client profile |
|
||||
@crecs = &get_data("clients.dat"); |
|
||||
$trash = join($pathsep, $dataroot, "clients.dat"); |
|
||||
open (TMPFILE, ">$trash"); |
|
||||
foreach $crec (@crecs) { |
|
||||
chop ($crec); |
|
||||
($id, $trash) = split(/&/, $crec); |
|
||||
if ($id eq $CLIENT{'clid'}) { |
|
||||
print ARCHFILE "$crec\n"; |
|
||||
print "client profile $id archived $! ...<BR>\n"; |
|
||||
} else { |
|
||||
print TMPFILE "$crec\n"; |
|
||||
} |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
|
|
||||
# delete administrative logins |
|
||||
@crecs = &get_data("admin.dat"); |
|
||||
$trash = join($pathsep, $dataroot, "admin.dat"); |
|
||||
open (TMPFILE, ">$trash"); |
|
||||
foreach $crec (@crecs) { |
|
||||
chop ($crec); |
|
||||
($id, $pwd, $pv, $clid) = split(/&/, $crec); |
|
||||
if ($clid eq $CLIENT{'clid'}) { |
|
||||
print ARCHFILE "$crec\n"; |
|
||||
print "admin login $id archived $! ...<BR>\n"; |
|
||||
} else { |
|
||||
print TMPFILE "$crec\n"; |
|
||||
} |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
close ARCHFILE; |
|
||||
$chmodok = chmod 0666, $archivefile; |
|
||||
|
|
||||
# delete logos |
|
||||
$ulinkdir = join($pathsep, $pubroot, "graphic"); |
|
||||
opendir (GDIR, $ulinkdir); |
|
||||
@dots = readdir(GDIR); |
|
||||
closedir GDIR; |
|
||||
$rmmask = "$CLIENT{'clid'}."; |
|
||||
foreach $rmfile (@dots) { |
|
||||
if ($rmfile =~ /$rmmask/ ) { |
|
||||
$ulinkfile = join($pathsep, $pubroot, "graphic", $rmfile); |
|
||||
$archivefile = $ulinkfile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $ulinkfile, $archivefile; |
|
||||
print "$ulinkfile archived $! ...<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
@dots = (); |
|
||||
|
|
||||
# delete cnd file |
|
||||
$tofile = join($pathsep, $dataroot, "cnd.$CLIENT{'clid'}"); |
|
||||
$archivefile = $tofile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $tofile, $archivefile; |
|
||||
print "$tofile archived $! ...<BR>\n"; |
|
||||
|
|
||||
# delete reports file |
|
||||
$tofile = join($pathsep, $dataroot, "reports.$CLIENT{'clid'}"); |
|
||||
$archivefile = $tofile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $tofile, $archivefile; |
|
||||
print "$tofile archived $! ...<BR>\n"; |
|
||||
|
|
||||
# delete tests file |
|
||||
$tofile = join($pathsep, $dataroot, "tests.$CLIENT{'clid'}"); |
|
||||
$archivefile = $tofile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $tofile, $archivefile; |
|
||||
print "$tofile archived $! ...<BR>\n"; |
|
||||
|
|
||||
# delete test graphic files |
|
||||
opendir (GDIR, $testgraphic); |
|
||||
@dots = readdir(GDIR); |
|
||||
closedir GDIR; |
|
||||
$rmmask = "$CLIENT{'clid'}."; |
|
||||
foreach $rmfile (@dots) { |
|
||||
if ($rmfile =~ /$rmmask/ ) { |
|
||||
$ulinkfile = join($pathsep, $testgraphic, $rmfile); |
|
||||
$archivefile = $ulinkfile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $ulinkfile, $archivefile; |
|
||||
print "$ulinkfile archived $! ...<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
@dots = (); |
|
||||
|
|
||||
# delete test questions files |
|
||||
opendir (GDIR, $questionroot); |
|
||||
@dots = readdir(GDIR); |
|
||||
closedir GDIR; |
|
||||
$rmmask = ".$CLIENT{'clid'}"; |
|
||||
foreach $rmfile (@dots) { |
|
||||
if ($rmfile =~ /$rmmask/ ) { |
|
||||
$ulinkfile = join($pathsep, $questionroot, $rmfile); |
|
||||
$archivefile = $ulinkfile; |
|
||||
$archivefile =~ s/$docroot/$archiveroot/g; |
|
||||
rename $ulinkfile, $archivefile; |
|
||||
print "$ulinkfile archived $! ...<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
@dots = (); |
|
||||
|
|
||||
# delete index page |
|
||||
$tofile = join($pathsep, $pubroot, "$CLIENT{'clid'}", "index.htm"); |
|
||||
$cnt = unlink $tofile; |
|
||||
print "$tofile deleted $! ...<BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub open_results { |
|
||||
print "<HTML> |
|
||||
<HEAD> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
function right(e) { |
|
||||
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) { |
|
||||
alert(\"<%=PHRASE.473%>\"); |
|
||||
return false; |
|
||||
} else { |
|
||||
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) { |
|
||||
alert(\"<%=PHRASE.473%>\"); |
|
||||
return false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
document.onmousedown=right; |
|
||||
document.onmouseup=right; |
|
||||
if (document.layers) window.captureEvents(Event.MOUSEDOWN); |
|
||||
if (document.layers) window.captureEvents(Event.MOUSEUP); |
|
||||
window.onmousedown=right; |
|
||||
window.onmouseup=right; |
|
||||
// --> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR==\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
"; |
|
||||
} |
|
||||
|
|
||||
sub close_results { |
|
||||
print "</BODY>\n</HTML>\n"; |
|
||||
} |
|
||||
@ -1,143 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: sitecfg.pl.default,v 1.2 2006/07/25 20:08:04 psims Exp $ |
|
||||
# |
|
||||
# Source File: sitecfg.pl |
|
||||
|
|
||||
require 'genutil.pl'; |
|
||||
require 'logger.pl'; |
|
||||
|
|
||||
$ipfilter = ""; |
|
||||
$acceptpost = 1; |
|
||||
$acceptget = 1; |
|
||||
$allowmultilogin = 0; |
|
||||
$blockrightclick = 1; # 1 for production, 0 for development. |
|
||||
$forcehttps = 0; |
|
||||
$autologout = 3600; |
|
||||
$clientDir_umask = 0775; # octal, for creating new client dirs |
|
||||
|
|
||||
$mmautontfyfrom="autonotify\@actscorp.com"; |
|
||||
$mmautontfyto="support\@actscorp.com"; |
|
||||
|
|
||||
$SYSTEM{Version} = "4.00"; |
|
||||
$SYSTEM{'ipfilter'} = $ipfilter; |
|
||||
$SYSTEM{'acceptpost'} = $acceptpost; |
|
||||
$SYSTEM{'acceptget'} = $acceptget; |
|
||||
$SYSTEM{'allowmultilogin'} = $allowmultilogin; |
|
||||
$SYSTEM{'blockrightclick'} = $blockrightclick; |
|
||||
$SYSTEM{'forcehttps'} = $forcehttps; |
|
||||
$SYSTEM{'autologout'} = $autologout; |
|
||||
$SYSTEM{'acceptpostchk'} = ($acceptpost == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'acceptgetchk'} = ($acceptget == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'allowmultiloginchk'} = ($allowmultilogin == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'supportedimagemedia'} = "art;bmp;gif;GIF;jpg;JPG;jpe;jpeg;png;PNG;pdf;PDF"; |
|
||||
$SYSTEM{'supportedaudiomedia'} = "aif;aifc;aiff;au;mid;rmi;snd;wav;"; |
|
||||
$SYSTEM{'supportedvideomedia'} = "avi;m1v;mov;mpa;mpe;mpeg;mpg"; |
|
||||
%CONTENT_TYPES=( |
|
||||
"aif" => "audio/x-aiff", |
|
||||
"aifc" => "audio/x-aiff", |
|
||||
"aiff" => "audio/x-aiff", |
|
||||
"art" => "image/x-jg", |
|
||||
"au" => "audio/basic", |
|
||||
"avi" => "video/avi", |
|
||||
"bmp" => "image/bmp", |
|
||||
"gif" => "image/gif", |
|
||||
"GIF" => "image/gif", |
|
||||
"jpe" => "image/jpeg", |
|
||||
"jpg" => "image/jpeg", |
|
||||
"JPG" => "image/jpeg", |
|
||||
"jpeg" => "image/jpeg", |
|
||||
"m1v" => "video/mpeg", |
|
||||
"mid" => "audio/mid", |
|
||||
"mov" => "video/quicktime", |
|
||||
"mpa" => "video/jpeg", |
|
||||
"mpe" => "video/jpeg", |
|
||||
"mpeg" => "video/jpeg", |
|
||||
"mpg" => "video/jpeg", |
|
||||
"pdf" => "application/pdf", |
|
||||
"PDF" => "application/pdf", |
|
||||
"png" => "image/png", |
|
||||
"PNG" => "image/png", |
|
||||
"rmi" => "audio/mid", |
|
||||
"snd" => "audio/basic", |
|
||||
"wav" => "audio/x-wav", |
|
||||
"other" => "text/html" |
|
||||
); |
|
||||
|
|
||||
$osnt=0; |
|
||||
$pathsep = "/"; |
|
||||
$colsep = '&'; |
|
||||
$fieldsep = ';'; |
|
||||
$idmax = 1000; |
|
||||
|
|
||||
$hostid = 4; |
|
||||
require 'smilib.pl'; |
|
||||
require 'cybertestlib.pl'; |
|
||||
require 'maillib.pl'; |
|
||||
|
|
||||
|
|
||||
# |
|
||||
# THIS IS DEVELOPMENT SETTING *ONLY*! DO NOT COMMIT THIS CHANGE!! |
|
||||
# |
|
||||
$docroot = $ENV{DOCUMENT_ROOT}; |
|
||||
$docroot =~ s/\/htdocs\s*$//g; |
|
||||
$urlroot = "/cgi-bin"; |
|
||||
$pubroot = join($pathsep, $docroot, "htdocs"); |
|
||||
$graphroot = join($pathsep, "", "graphic"); |
|
||||
$graphurl = join($pathsep, "", "graphic"); |
|
||||
$cgiroot = $urlroot; |
|
||||
$cfgroot = join($pathsep, $docroot, "cgi-bin"); |
|
||||
|
|
||||
$archiveroot = join($pathsep, $docroot, "archive"); |
|
||||
$secroot = join($pathsep, $docroot, "secure_html"); |
|
||||
$logroot = join($pathsep, $secroot, "log"); |
|
||||
$resptmplt = join($pathsep, $secroot, "template"); |
|
||||
$dataroot = join($pathsep, $secroot, "data"); |
|
||||
$questionroot = join($pathsep, $dataroot, "tests"); |
|
||||
$testgraphic = join($pathsep, $questionroot, "graphic"); |
|
||||
$testroot = join($pathsep, $secroot, "tests"); |
|
||||
$testpending = join($pathsep, $secroot, "tests", "pending"); |
|
||||
$testinprog = join($pathsep, $secroot, "tests", "inprog"); |
|
||||
$testcomplete = join($pathsep, $secroot, "tests", "complete"); |
|
||||
#$mail_server_domain = "mail.actscorp.com"; |
|
||||
$mail_server_domain = "localhost"; |
|
||||
#for above line, for Unix use smtp name from /etc/rc.config, for W2K use domain name or |
|
||||
#IP address where TestManager is running |
|
||||
|
|
||||
$PATHS{'graphroot'} = $graphroot; |
|
||||
$PATHS{'graphurl'} = $graphurl; |
|
||||
$PATHS{'cgiroot'} = $cgiroot; |
|
||||
$PATHS{'pubroot'} = $pubroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'dataroot'} = $dataroot; |
|
||||
$PATHS{'secroot'} = $secroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'resptmplt'} = $resptmplt; |
|
||||
$PATHS{'questionroot'} = $questionroot; |
|
||||
$PATHS{'testroot'} = $testroot; |
|
||||
$PATHS{'urlroot'} = $urlroot; |
|
||||
$PATHS{'archiveroot'} = $archiveroot; |
|
||||
$PATHS{'download'} = $download; |
|
||||
|
|
||||
# |
|
||||
# This require MUST BE AFTER %PATHS because it calls routines in SMILIB using |
|
||||
# the paths from above to load English as the default language. |
|
||||
# |
|
||||
require 'languagelib.pl'; |
|
||||
|
|
||||
######################################################################## |
|
||||
#################### UI Utility Settings & Functions ########### |
|
||||
######################################################################## |
|
||||
$UI{ERROR_FONT_COLOR} = "#FF0000"; |
|
||||
$UI{ERROR_BG_COLOR} = "#000000"; |
|
||||
$UI{OK_FONT_COLOR} = "#00FF00"; |
|
||||
$UI{OK_BG_COLOR} = "#000000"; |
|
||||
$UI{PCNT_FMT} = "%.1f"; # format for percentages (see perldoc -f sprintf) |
|
||||
$UI{DATETIME_FMT} = "%b %e, %Y, %l:%M %p %Z"; # format for datetimes |
|
||||
$UI{DEFAULT_AVAILON_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILON_MIN} = 0; # 0-59 |
|
||||
$UI{DEFAULT_AVAILTHRU_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILTHRU_MIN} = 0; # 0-59 |
|
||||
|
|
||||
# end with True because this is a require file |
|
||||
1 |
|
||||
@ -1,147 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: sitecfg.pl.default,v 1.2 2006/07/25 20:08:04 psims Exp $ |
|
||||
# |
|
||||
# Source File: sitecfg.pl |
|
||||
|
|
||||
require 'genutil.pl'; |
|
||||
require 'logger.pl'; |
|
||||
|
|
||||
$ipfilter = ""; |
|
||||
$acceptpost = 1; |
|
||||
$acceptget = 1; |
|
||||
$allowmultilogin = 0; |
|
||||
$blockrightclick = 1; # 1 for production, 0 for development. |
|
||||
$forcehttps = 0; |
|
||||
$autologout = 3600; |
|
||||
$clientDir_umask = 0775; # octal, for creating new client dirs |
|
||||
|
|
||||
$mmautontfyfrom="autonotify\@actscorp.com"; |
|
||||
$mmautontfyto="support\@actscorp.com"; |
|
||||
|
|
||||
$SYSTEM{Version} = "4.00"; |
|
||||
$SYSTEM{'ipfilter'} = $ipfilter; |
|
||||
$SYSTEM{'acceptpost'} = $acceptpost; |
|
||||
$SYSTEM{'acceptget'} = $acceptget; |
|
||||
$SYSTEM{'allowmultilogin'} = $allowmultilogin; |
|
||||
$SYSTEM{'blockrightclick'} = $blockrightclick; |
|
||||
$SYSTEM{'forcehttps'} = $forcehttps; |
|
||||
$SYSTEM{'autologout'} = $autologout; |
|
||||
$SYSTEM{'acceptpostchk'} = ($acceptpost == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'acceptgetchk'} = ($acceptget == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'allowmultiloginchk'} = ($allowmultilogin == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'supportedimagemedia'} = "art;bmp;gif;GIF;jpg;JPG;jpe;jpeg;png;PNG;pdf;PDF"; |
|
||||
$SYSTEM{'supportedaudiomedia'} = "aif;aifc;aiff;au;mid;rmi;snd;wav;mp3;MP3"; |
|
||||
$SYSTEM{'supportedvideomedia'} = "avi;m1v;mov;mpa;mpe;mpeg;mpg;mp4;MP4"; |
|
||||
%CONTENT_TYPES=( |
|
||||
"aif" => "audio/x-aiff", |
|
||||
"aifc" => "audio/x-aiff", |
|
||||
"aiff" => "audio/x-aiff", |
|
||||
"art" => "image/x-jg", |
|
||||
"au" => "audio/basic", |
|
||||
"avi" => "video/avi", |
|
||||
"bmp" => "image/bmp", |
|
||||
"gif" => "image/gif", |
|
||||
"GIF" => "image/gif", |
|
||||
"jpe" => "image/jpeg", |
|
||||
"jpg" => "image/jpeg", |
|
||||
"JPG" => "image/jpeg", |
|
||||
"jpeg" => "image/jpeg", |
|
||||
"m1v" => "video/mpeg", |
|
||||
"mid" => "audio/mid", |
|
||||
"mov" => "video/quicktime", |
|
||||
"mp3" => "audio/mpeg", |
|
||||
"MP3" => "audio/mpeg", |
|
||||
"mp4" => "video/mp4", |
|
||||
"MP4" => "video/mp4", |
|
||||
"mpa" => "video/jpeg", |
|
||||
"mpe" => "video/jpeg", |
|
||||
"mpeg" => "video/jpeg", |
|
||||
"mpg" => "video/jpeg", |
|
||||
"pdf" => "application/pdf", |
|
||||
"PDF" => "application/pdf", |
|
||||
"png" => "image/png", |
|
||||
"PNG" => "image/png", |
|
||||
"rmi" => "audio/mid", |
|
||||
"snd" => "audio/basic", |
|
||||
"wav" => "audio/x-wav", |
|
||||
"other" => "text/html" |
|
||||
); |
|
||||
|
|
||||
$osnt=0; |
|
||||
$pathsep = "/"; |
|
||||
$colsep = '&'; |
|
||||
$fieldsep = ';'; |
|
||||
$idmax = 1000; |
|
||||
|
|
||||
$hostid = 4; |
|
||||
require 'smilib.pl'; |
|
||||
require 'cybertestlib.pl'; |
|
||||
require 'maillib.pl'; |
|
||||
|
|
||||
|
|
||||
# |
|
||||
# THIS IS DEVELOPMENT SETTING *ONLY*! DO NOT COMMIT THIS CHANGE!! |
|
||||
# |
|
||||
$docroot = $ENV{DOCUMENT_ROOT}; |
|
||||
$docroot =~ s/\/htdocs\s*$//g; |
|
||||
$urlroot = "/cgi-bin"; |
|
||||
$pubroot = join($pathsep, $docroot, "htdocs"); |
|
||||
$graphroot = join($pathsep, "", "graphic"); |
|
||||
$graphurl = join($pathsep, "", "graphic"); |
|
||||
$cgiroot = $urlroot; |
|
||||
$cfgroot = join($pathsep, $docroot, "cgi-bin"); |
|
||||
|
|
||||
$archiveroot = join($pathsep, $docroot, "archive"); |
|
||||
$secroot = join($pathsep, $docroot, "secure_html"); |
|
||||
$logroot = join($pathsep, $secroot, "log"); |
|
||||
$resptmplt = join($pathsep, $secroot, "template"); |
|
||||
$dataroot = join($pathsep, $secroot, "data"); |
|
||||
$questionroot = join($pathsep, $dataroot, "tests"); |
|
||||
$testgraphic = join($pathsep, $questionroot, "graphic"); |
|
||||
$testroot = join($pathsep, $secroot, "tests"); |
|
||||
$testpending = join($pathsep, $secroot, "tests", "pending"); |
|
||||
$testinprog = join($pathsep, $secroot, "tests", "inprog"); |
|
||||
$testcomplete = join($pathsep, $secroot, "tests", "complete"); |
|
||||
#$mail_server_domain = "mail.actscorp.com"; |
|
||||
$mail_server_domain = "localhost"; |
|
||||
#for above line, for Unix use smtp name from /etc/rc.config, for W2K use domain name or |
|
||||
#IP address where TestManager is running |
|
||||
|
|
||||
$PATHS{'graphroot'} = $graphroot; |
|
||||
$PATHS{'graphurl'} = $graphurl; |
|
||||
$PATHS{'cgiroot'} = $cgiroot; |
|
||||
$PATHS{'pubroot'} = $pubroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'dataroot'} = $dataroot; |
|
||||
$PATHS{'secroot'} = $secroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'resptmplt'} = $resptmplt; |
|
||||
$PATHS{'questionroot'} = $questionroot; |
|
||||
$PATHS{'testroot'} = $testroot; |
|
||||
$PATHS{'urlroot'} = $urlroot; |
|
||||
$PATHS{'archiveroot'} = $archiveroot; |
|
||||
$PATHS{'download'} = $download; |
|
||||
|
|
||||
# |
|
||||
# This require MUST BE AFTER %PATHS because it calls routines in SMILIB using |
|
||||
# the paths from above to load English as the default language. |
|
||||
# |
|
||||
require 'languagelib.pl'; |
|
||||
|
|
||||
######################################################################## |
|
||||
#################### UI Utility Settings & Functions ########### |
|
||||
######################################################################## |
|
||||
$UI{ERROR_FONT_COLOR} = "#FF0000"; |
|
||||
$UI{ERROR_BG_COLOR} = "#000000"; |
|
||||
$UI{OK_FONT_COLOR} = "#00FF00"; |
|
||||
$UI{OK_BG_COLOR} = "#000000"; |
|
||||
$UI{PCNT_FMT} = "%.1f"; # format for percentages (see perldoc -f sprintf) |
|
||||
$UI{DATETIME_FMT} = "%b %e, %Y, %l:%M %p %Z"; # format for datetimes |
|
||||
$UI{DEFAULT_AVAILON_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILON_MIN} = 0; # 0-59 |
|
||||
$UI{DEFAULT_AVAILTHRU_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILTHRU_MIN} = 0; # 0-59 |
|
||||
|
|
||||
# end with True because this is a require file |
|
||||
1 |
|
||||
@ -1,148 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: sitecfg.pl.default,v 1.2 2006/07/25 20:08:04 psims Exp $ |
|
||||
# |
|
||||
# Source File: sitecfg.pl |
|
||||
|
|
||||
require 'genutil.pl'; |
|
||||
require 'logger.pl'; |
|
||||
|
|
||||
$ipfilter = ""; |
|
||||
$acceptpost = 1; |
|
||||
$acceptget = 1; |
|
||||
$allowmultilogin = 0; |
|
||||
$blockrightclick = 1; # 1 for production, 0 for development. |
|
||||
$forcehttps = 0; |
|
||||
$autologout = 3600; |
|
||||
$clientDir_umask = 0775; # octal, for creating new client dirs |
|
||||
|
|
||||
$mmautontfyfrom="autonotify\@actscorp.com"; |
|
||||
$mmautontfyto="support\@actscorp.com"; |
|
||||
|
|
||||
$SYSTEM{Version} = "4.00"; |
|
||||
$SYSTEM{'ipfilter'} = $ipfilter; |
|
||||
$SYSTEM{'acceptpost'} = $acceptpost; |
|
||||
$SYSTEM{'acceptget'} = $acceptget; |
|
||||
$SYSTEM{'allowmultilogin'} = $allowmultilogin; |
|
||||
$SYSTEM{'blockrightclick'} = $blockrightclick; |
|
||||
$SYSTEM{'forcehttps'} = $forcehttps; |
|
||||
$SYSTEM{'autologout'} = $autologout; |
|
||||
$SYSTEM{'acceptpostchk'} = ($acceptpost == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'acceptgetchk'} = ($acceptget == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'allowmultiloginchk'} = ($allowmultilogin == 1) ? "CHECKED" : ""; |
|
||||
$SYSTEM{'supportedimagemedia'} = "art;bmp;gif;GIF;jpg;JPG;jpe;jpeg;png;PNG;pdf;PDF"; |
|
||||
$SYSTEM{'supportedaudiomedia'} = "aif;aifc;aiff;au;mid;rmi;snd;wav;mp3;MP3"; |
|
||||
$SYSTEM{'supportedvideomedia'} = "avi;m1v;mov;mpa;mpe;mpeg;mpg;mp4;MP4"; |
|
||||
%CONTENT_TYPES=( |
|
||||
"aif" => "audio/x-aiff", |
|
||||
"aifc" => "audio/x-aiff", |
|
||||
"aiff" => "audio/x-aiff", |
|
||||
"art" => "image/x-jg", |
|
||||
"au" => "audio/basic", |
|
||||
"avi" => "video/avi", |
|
||||
"bmp" => "image/bmp", |
|
||||
"gif" => "image/gif", |
|
||||
"GIF" => "image/gif", |
|
||||
"jpe" => "image/jpeg", |
|
||||
"jpg" => "image/jpeg", |
|
||||
"JPG" => "image/jpeg", |
|
||||
"jpeg" => "image/jpeg", |
|
||||
"m1v" => "video/mpeg", |
|
||||
"mid" => "audio/mid", |
|
||||
"mov" => "video/quicktime", |
|
||||
"mp3" => "audio/mpeg", |
|
||||
"MP3" => "audio/mpeg", |
|
||||
"mp4" => "video/mp4", |
|
||||
"MP4" => "video/mp4", |
|
||||
"mpa" => "video/jpeg", |
|
||||
"mpe" => "video/jpeg", |
|
||||
"mpeg" => "video/jpeg", |
|
||||
"mpg" => "video/jpeg", |
|
||||
"pdf" => "application/pdf", |
|
||||
"PDF" => "application/pdf", |
|
||||
"png" => "image/png", |
|
||||
"PNG" => "image/png", |
|
||||
"rmi" => "audio/mid", |
|
||||
"snd" => "audio/basic", |
|
||||
"wav" => "audio/x-wav", |
|
||||
"other" => "text/html" |
|
||||
); |
|
||||
|
|
||||
$osnt=0; |
|
||||
$pathsep = "/"; |
|
||||
$colsep = '&'; |
|
||||
$fieldsep = ';'; |
|
||||
$idmax = 1000; |
|
||||
|
|
||||
$hostid = 4; |
|
||||
require 'smilib.pl'; |
|
||||
require 'cybertestlib.pl'; |
|
||||
require 'maillib.pl'; |
|
||||
|
|
||||
|
|
||||
# |
|
||||
# THIS IS DEVELOPMENT SETTING *ONLY*! DO NOT COMMIT THIS CHANGE!! |
|
||||
# |
|
||||
$docroot = $ENV{DOCUMENT_ROOT}; |
|
||||
$docroot =~ s/\/htdocs\s*$//g; |
|
||||
$urlroot = "/cgi-bin"; |
|
||||
$pubroot = join($pathsep, $docroot, "htdocs"); |
|
||||
$graphroot = join($pathsep, "", "graphic"); |
|
||||
$graphurl = join($pathsep, "", "graphic"); |
|
||||
$cgiroot = $urlroot; |
|
||||
$cfgroot = join($pathsep, $docroot, "cgi-bin"); |
|
||||
|
|
||||
$archiveroot = join($pathsep, $docroot, "archive"); |
|
||||
$secroot = join($pathsep, $docroot, "secure_html"); |
|
||||
$logroot = join($pathsep, $secroot, "log"); |
|
||||
$resptmplt = join($pathsep, $secroot, "template"); |
|
||||
$dataroot = join($pathsep, $secroot, "data"); |
|
||||
$questionroot = join($pathsep, $dataroot, "tests"); |
|
||||
$testgraphic = join($pathsep, $questionroot, "graphic"); |
|
||||
$testroot = join($pathsep, $secroot, "tests"); |
|
||||
$testpending = join($pathsep, $secroot, "tests", "pending"); |
|
||||
$testinprog = join($pathsep, $secroot, "tests", "inprog"); |
|
||||
$testcomplete = join($pathsep, $secroot, "tests", "complete"); |
|
||||
#$mail_server_domain = "mail.actscorp.com"; |
|
||||
$mail_server_domain = "localhost"; |
|
||||
#for above line, for Unix use smtp name from /etc/rc.config, for W2K use domain name or |
|
||||
#IP address where TestManager is running |
|
||||
|
|
||||
$PATHS{'graphroot'} = $graphroot; |
|
||||
$PATHS{'graphurl'} = $graphurl; |
|
||||
$PATHS{'cgiroot'} = $cgiroot; |
|
||||
$PATHS{'pubroot'} = $pubroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'dataroot'} = $dataroot; |
|
||||
$PATHS{'secroot'} = $secroot; |
|
||||
$PATHS{'logroot'} = $logroot; |
|
||||
$PATHS{'resptmplt'} = $resptmplt; |
|
||||
$PATHS{'questionroot'} = $questionroot; |
|
||||
$PATHS{'testroot'} = $testroot; |
|
||||
$PATHS{'urlroot'} = $urlroot; |
|
||||
$PATHS{'archiveroot'} = $archiveroot; |
|
||||
$PATHS{'download'} = $download; |
|
||||
|
|
||||
# |
|
||||
# This require MUST BE AFTER %PATHS because it calls routines in SMILIB using |
|
||||
# the paths from above to load English as the default language. |
|
||||
# |
|
||||
require 'languagelib.pl'; |
|
||||
|
|
||||
######################################################################## |
|
||||
#################### UI Utility Settings & Functions ########### |
|
||||
######################################################################## |
|
||||
$UI{ERROR_FONT_COLOR} = "#FF0000"; |
|
||||
$UI{ERROR_BG_COLOR} = "#000000"; |
|
||||
$UI{OK_FONT_COLOR} = "#00FF00"; |
|
||||
$UI{OK_BG_COLOR} = "#000000"; |
|
||||
$UI{PCNT_FMT} = "%.1f"; # format for percentages (see perldoc -f sprintf) |
|
||||
$UI{DATETIME_FMT} = "%b %e, %Y, %l:%M %p %Z"; # format for datetimes |
|
||||
$UI{DEFAULT_AVAILON_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILON_MIN} = 0; # 0-59 |
|
||||
$UI{DEFAULT_AVAILTHRU_YEAR} = 2030; # Actual year. |
|
||||
$UI{DEFAULT_AVAILTHRU_HR} = 0; # 0-23 |
|
||||
$UI{DEFAULT_AVAILTHRU_MIN} = 0; # 0-59 |
|
||||
|
|
||||
# end with True because this is a require file |
|
||||
1 |
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,562 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: sreports.pl,v 1.4 2006/01/23 21:39:30 ddoughty Exp $ |
|
||||
# |
|
||||
# Source File: sreports.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'tstatlib.pl'; |
|
||||
|
|
||||
$FORM{'frm'}=""; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
$REPORT{'rptid'}=""; |
|
||||
@rptdefs = &get_data("sitereports.dat"); |
|
||||
@lbls = split(/&/, $rptdefs[0]); |
|
||||
foreach $rptdef (@rptdefs) { |
|
||||
chomp ($rptdef); |
|
||||
@flds = split(/&/, $rptdef); |
|
||||
if ($flds[0] eq $FORM{'rptno'}) { |
|
||||
for $i (0 .. $#lbls) { |
|
||||
$REPORT{$lbls[$i]} = $flds[$i]; |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
if ($FORM{'frm'} == '1' || ($FORM{'frm'} == '' && $REPORT{'rptid'} eq "ACT-004")) { |
|
||||
&show_index; |
|
||||
} else { |
|
||||
if ($FORM{'frm'} == '2') { |
|
||||
&show_detail; |
|
||||
} |
|
||||
else { |
|
||||
if ($FORM{'frm'} == '') { |
|
||||
&show_frames; |
|
||||
} else { |
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD></HEAD>\n"; |
|
||||
print "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
</BODY>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub show_frames { |
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD></HEAD>\n"; |
|
||||
print "<FRAMESET frameborder=0 cols=\"30%,*\">\n"; |
|
||||
print "<FRAME name=\"rptindex\" frameborder=0 src=\"$cgiroot/sreports.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=1&rptno=$FORM{'rptno'}\">\n"; |
|
||||
print "<FRAME name=\"rptdetail\" frameborder=0 src=\"$cgiroot/sreports.pl?lang=$SESSION{'lang'}&tid=$SESSION{'tid'}&frm=0\">\n"; |
|
||||
print "</FRAMESET>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub show_index { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}"); |
|
||||
print "<HTML>\n"; |
|
||||
print "<HEAD>\n<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE>\n</HEAD>\n"; |
|
||||
print "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
\n"; |
|
||||
print "<B>$REPORT{'rptid'}<BR>$REPORT{'rptdesc'}</B><BR> <BR>\n"; |
|
||||
if ($REPORT{'rptid'} eq 'ACT-001') { |
|
||||
opendir(DIR, "$logroot"); |
|
||||
@dircon = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
@sdircon = sort @dircon; |
|
||||
foreach $diritem (@sdircon) { |
|
||||
chomp ($diritem); |
|
||||
if ($diritem =~ /sess\.[0-9]/i ) { |
|
||||
@lines = &get_log($diritem); |
|
||||
foreach $line (@lines) { |
|
||||
chomp ($line); |
|
||||
($nm,$vlu)=split(/=/, $line); |
|
||||
$SESS{$nm}=$vlu; |
|
||||
} |
|
||||
$tmstr = &format_date_time("yy-mm-dd hh:nn", "1", "-10000", substr($SESS{'tid'}, 0, -4)); |
|
||||
print "<FONT SIZE=2>$tmstr</FONT> <A HREF=\"$cgiroot/sreports.pl?tid=$SESSION{'tid'}&frm=2&rptno=$FORM{'rptno'}&dbfile=$SESS{'clid'}.$SESS{'uid'}&filter=$SESS{'tid'}\" TARGET=\"rptdetail\">$SESS{'uid'}.$SESS{'clid'}</A><BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
} elsif ($REPORT{'rptid'} eq 'ACT-002') { |
|
||||
print "<HR WIDTH=\"100%\">\n"; |
|
||||
print "<B>Tests Pending:</B><BR>\n"; |
|
||||
opendir(DIR, "$testpending"); |
|
||||
@dircon = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
@sdircon = sort @dircon; |
|
||||
foreach $diritem (@sdircon) { |
|
||||
chomp ($diritem); |
|
||||
if ($diritem =~ /[a-zA-Z0-9](.*).[a-zA-Z0-9](.*).[a-zA-Z0-9]/i ) { |
|
||||
print "<FONT SIZE=2><A HREF=\"$cgiroot/sreports.pl?tid=$SESSION{'tid'}&frm=2&location=0&rptno=$FORM{'rptno'}&dbfile=$diritem\" TARGET=\"rptdetail\">$diritem</A></FONT><BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
print "<HR WIDTH=\"100%\">\n"; |
|
||||
print "<B>Tests in Progress:</B><BR>\n"; |
|
||||
opendir(DIR, "$testinprog"); |
|
||||
@dircon = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
@sdircon = sort @dircon; |
|
||||
foreach $diritem (@sdircon) { |
|
||||
chomp ($diritem); |
|
||||
if ($diritem =~ /[a-zA-Z0-9](.*).[a-zA-Z0-9](.*).[a-zA-Z0-9]/i ) { |
|
||||
print "<FONT SIZE=2><A HREF=\"$cgiroot/sreports.pl?tid=$SESSION{'tid'}&frm=2&location=1&rptno=$FORM{'rptno'}&dbfile=$diritem\" TARGET=\"rptdetail\">$diritem</A></FONT><BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
print "<HR WIDTH=\"100%\">\n"; |
|
||||
print "<B>Tests Completed:</B><BR>\n"; |
|
||||
opendir(DIR, "$testcomplete"); |
|
||||
@dircon = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
@sdircon = sort @dircon; |
|
||||
foreach $diritem (@sdircon) { |
|
||||
chomp ($diritem); |
|
||||
if ($diritem =~ /[a-zA-Z0-9](.*).[a-zA-Z0-9](.*).[a-zA-Z0-9]/i ) { |
|
||||
print "<FONT SIZE=2><A HREF=\"$cgiroot/sreports.pl?tid=$SESSION{'tid'}&frm=2&location=2&rptno=$FORM{'rptno'}&dbfile=$diritem\" TARGET=\"rptdetail\">$diritem</A></FONT><BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
} elsif ($REPORT{'rptid'} eq 'ACT-004') { |
|
||||
# C_004 |
|
||||
$faction="$cgiroot/IntegroStats.pl"; |
|
||||
$ftarget="rptwindow"; |
|
||||
$fparms="<input type=hidden name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"tstid\" value=\"\">\n"); |
|
||||
### DED 10/25/2002 Added rptdesc and rptid to pass to creportsf |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"); |
|
||||
$fparms=join('',$fparms,"<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"); |
|
||||
$finputs="<table cellpadding=2 border=1>\n"; |
|
||||
$finputs=join('',$finputs,"\t<tr>\n\t\t<td colspan=3 align=center valign=top>Advanced Options<br></td>\n</tr>\n"); |
|
||||
|
|
||||
$finputs=join('',$finputs,"<tr>\n"); |
|
||||
$finputs=join('',$finputs,"\t\t<td valign=top><font size=2>\n<i>Question Statistics:</i><br>\n"); |
|
||||
$finputs=join('',$finputs,"<input type=radio name=\"testsummary\" value=\"composite\" onClick=\"return reportOptions(this)\"> Question Statistics<br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"showobs\" onClick=\"return reportOptions(this)\"> include inactive questions<br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"exnoresp\"> exclude No Response from stats<br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<i>User Comments:</i><br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=radio name=\"showcmts\" value=\"donot\" onClick=\"return reportOptions(this)\"> do not include<br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=radio name=\"showcmts\" value=\"withq\" onClick=\"return reportOptions(this)\"> include with question<br>\n"); |
|
||||
$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=radio name=\"showcmts\" value=\"atend\" onClick=\"return reportOptions(this)\"> include at end<br>\n"); |
|
||||
$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
|
|
||||
### DED 12/23/04 Removed Test Stats & Other Options |
|
||||
#$finputs=join('',$finputs,"\t\t<td valign=top><font size=2>\n<i>Test Statistics</i><br>\n"); |
|
||||
#$finputs=join('',$finputs,"<input type=radio name=\"testsummary\" value=\"bycnd\" onClick=\"return reportOptions(this)\"> Individual Test results<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"statsbysubj\" onClick=\"return reportOptions(this)\"> breakdown by subject area<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
|
|
||||
#$finputs=join('',$finputs,"\t\t<td valign=top><font size=2>\n<i>Other Options:</i><br>"); |
|
||||
#$finputs=join('',$finputs,"<input type=radio name=\"testsummary\" value=\"extractemail\" onClick=\"return reportOptions(this)\"> Extract From Tests<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"cndnme\" onClick=\"return reportOptions(this)\"> Candidate Name<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"cndeml\" onClick=\"return reportOptions(this)\"> Candidate Email Address<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\ \;\ \;\ \;\ \;\ \;<input type=checkbox name=\"cndscr\" onClick=\"return reportOptions(this)\"> Candidate Score<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
$finputs=join('',$finputs,"\t</tr>\n"); |
|
||||
|
|
||||
$finputs=join('',$finputs,"\t</tr>\n"); |
|
||||
$finputs=join('',$finputs,"\t\t<td align=left valign=top><font size=2>\n"); |
|
||||
### DED 12/23/04 |
|
||||
### Removed Filter-by-question options |
|
||||
#$finputs=join('',$finputs,"\ \;<br>\n"); |
|
||||
#$finputs=join('',$finputs,"<input type=checkbox name=\"filterbyques\" onClick=\"return filterCheck(this.form)\"> Filter by question<br>\n"); |
|
||||
#$finputs=join('',$finputs,"<input type=checkbox name=\"specfilter\" onClick=\"return filterCheck(this.form)\"> Filter by user<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t<td align=right valign=top><font size=2>\n"); |
|
||||
#my $j; |
|
||||
#$finputs=join('',$finputs,"From: <select name=\"mofm\">\n"); |
|
||||
#for $i (526 .. 537) { |
|
||||
#$j=$i-525; |
|
||||
#$finputs=join('',$finputs,"<option value=\"$j\">$xlatphrase[$i]\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><select name=\"dyfm\">\n"); |
|
||||
#for $i (1 .. 31) { |
|
||||
#$finputs=join('',$finputs,"<option value=\"$i\">$i\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><select name=\"yrfm\">\n"); |
|
||||
#for $i (2000 .. 2099) { |
|
||||
#$finputs=join('',$finputs,"<option value=\"$i\">$i\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><br>\n"); |
|
||||
#$finputs=join('',$finputs,"To: <select name=\"moto\">\n"); |
|
||||
#for $i (526 .. 537) { |
|
||||
#$j=$i-525; |
|
||||
#$finputs=join('',$finputs,"<option value=\"$j\">$xlatphrase[$i]\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><select name=\"dyto\">\n"); |
|
||||
#for $i (1 .. 31) { |
|
||||
#$finputs=join('',$finputs,"<option value=\"$i\">$i\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><select name=\"yrto\">\n"); |
|
||||
#for $i (2000 .. 2099) { |
|
||||
#$finputs=join('',$finputs,"<option value=\"$i\">$i\n"); |
|
||||
#} |
|
||||
#$finputs=join('',$finputs,"</select><br>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t<td align=right valign=top><font size=2>\n"); |
|
||||
#$finputs=join('',$finputs,"<input type=checkbox name=\"export\" onClick=\"return reportOptions(this)\"> download in text format<br>\n"); |
|
||||
#$finputs=join('',$finputs,"\t\t</font></td>\n"); |
|
||||
$finputs=join('',$finputs,"\t</tr>\n"); |
|
||||
|
|
||||
$finputs=join('',$finputs,"</table>\ \;<br>\n"); |
|
||||
$fjscript=" |
|
||||
function onWdwLoad() { |
|
||||
var oform=document.rptform1; |
|
||||
//oform.mofm.selectedIndex=0; |
|
||||
//oform.dyfm.selectedIndex=0; |
|
||||
//oform.yrfm.selectedIndex=0; |
|
||||
//oform.moto.selectedIndex=oform.moto.options.length-1; |
|
||||
//oform.dyto.selectedIndex=oform.dyto.options.length-1; |
|
||||
//oform.yrto.selectedIndex=oform.yrto.options.length-1; |
|
||||
//oform.testsummary[0].checked=true; |
|
||||
oform.testsummary.checked=true; |
|
||||
oform.showcmts[0].checked=true; |
|
||||
} |
|
||||
function filterCheck(oform) { |
|
||||
if (oform.specfilter.checked==true || oform.filterbyques.checked==true) { |
|
||||
oform.action=\"$cgiroot/creportsf.pl\"; |
|
||||
} else { |
|
||||
oform.action=\"$cgiroot/teststats.pl\"; |
|
||||
} |
|
||||
} |
|
||||
function parmsC004(oform,tst) { |
|
||||
oform.tstid.value=tst; |
|
||||
oform.submit(); |
|
||||
} |
|
||||
function reportOptions(oinp) { |
|
||||
var oform=oinp.form,idx; |
|
||||
if (oinp.name==\"testsummary\") { |
|
||||
idx=(oform.testsummary[0].checked) ? 0 : -1; |
|
||||
idx=(oform.testsummary[1].checked) ? 1 : idx; |
|
||||
idx=(oform.testsummary[2].checked) ? 2 : idx; |
|
||||
return testsummaryClick(oform,idx); |
|
||||
} else { |
|
||||
if (oinp.name==\"showcmts\") { |
|
||||
idx=(oform.showcmts[0].checked) ? 0 : -1; |
|
||||
idx=(oform.showcmts[1].checked) ? 1 : idx; |
|
||||
idx=(oform.showcmts[2].checked) ? 2 : idx; |
|
||||
return showcmtsClick(oform,idx); |
|
||||
} else { |
|
||||
if (oinp.name==\"statsbysubj\") { |
|
||||
return statsbysubjClick(oform,oinp.checked); |
|
||||
} else { |
|
||||
if (oinp.name==\"showobs\") { |
|
||||
return showobsClick(oform,oinp.checked); |
|
||||
} else { |
|
||||
if (oinp.name==\"export\") { |
|
||||
return exportClick(oform,oinp.checked); |
|
||||
} else { |
|
||||
return dataextractOpts(oform); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
function dataextractOpts(oform) { |
|
||||
if (!(oform.testsummary[2].checked)) { |
|
||||
oform.testsummary[2].checked=true; |
|
||||
oform.showcmts[0].checked=false; |
|
||||
oform.showcmts[1].checked=false; |
|
||||
oform.showcmts[2].checked=false; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
function testsummaryClick(oform,i) { |
|
||||
if (i==0) { |
|
||||
if (!((oform.showcmts[0].checked) || (oform.showcmts[1].checked) || (oform.showcmts[2].checked))) { |
|
||||
oform.showcmts[0].checked=true; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
oform.cndnme.checked=false; |
|
||||
oform.cndeml.checked=false; |
|
||||
if (\"$CLIENT{'clcnd1'}\" != \"\") { |
|
||||
oform.cnd1.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd2'}\" != \"\") { |
|
||||
oform.cnd2.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd3'}\" != \"\") { |
|
||||
oform.cnd3.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd4'}\" != \"\") { |
|
||||
oform.cnd4.checked=false; |
|
||||
} |
|
||||
oform.cndscr.checked=false; |
|
||||
} |
|
||||
} else { |
|
||||
if (i==1) { |
|
||||
oform.showcmts[0].checked=false; |
|
||||
oform.showcmts[1].checked=false; |
|
||||
oform.showcmts[2].checked=false; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
oform.cndnme.checked=false; |
|
||||
oform.cndeml.checked=false; |
|
||||
if (\"$CLIENT{'clcnd1'}\" != \"\") { |
|
||||
oform.cnd1.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd2'}\" != \"\") { |
|
||||
oform.cnd2.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd3'}\" != \"\") { |
|
||||
oform.cnd3.checked=false; |
|
||||
} |
|
||||
if (\"$CLIENT{'clcnd4'}\" != \"\") { |
|
||||
oform.cnd4.checked=false; |
|
||||
} |
|
||||
oform.cndscr.checked=false; |
|
||||
} else { |
|
||||
if (i==2) { |
|
||||
oform.showcmts[0].checked=false; |
|
||||
oform.showcmts[1].checked=false; |
|
||||
oform.showcmts[2].checked=false; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
function showcmtsClick(oform,i) { |
|
||||
if (!(oform.testsummary[0].checked)) { |
|
||||
oform.testsummary[0].checked=true; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
function statsbysubjClick(oform,chkd) { |
|
||||
if (chkd) { |
|
||||
if (!(oform.testsummary[1].checked)) { |
|
||||
oform.testsummary[1].checked=true; |
|
||||
oform.showcmts[0].checked=false; |
|
||||
oform.showcmts[1].checked=false; |
|
||||
oform.showcmts[2].checked=false; |
|
||||
oform.showobs.checked=false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
function showobsClick(oform,chkd) { |
|
||||
if (chkd) { |
|
||||
if (!(oform.testsummary[0].checked)) { |
|
||||
oform.testsummary[0].checked=true; |
|
||||
oform.showcmts[0].checked=true; |
|
||||
oform.statsbysubj.checked=false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
function exportClick(oform,chkd) { |
|
||||
return true; |
|
||||
} |
|
||||
window.onload=onWdwLoad; |
|
||||
"; |
|
||||
print "<HTML> |
|
||||
<HEAD> |
|
||||
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
$fjscript |
|
||||
function right(e) { |
|
||||
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} else { |
|
||||
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
//document.onmousedown=right; |
|
||||
//document.onmouseup=right; |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEDOWN); |
|
||||
//if (document.layers) window.captureEvents(Event.MOUSEUP); |
|
||||
//window.onmousedown=right; |
|
||||
//window.onmouseup=right; |
|
||||
// --> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
"; |
|
||||
print "<FORM name=\"rptform1\" action=\"$faction\" METHOD=POST target=\"$ftarget\">\n$fparms\n"; |
|
||||
|
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=100\%> |
|
||||
<TR> |
|
||||
<TD VALIGN=\"top\">$CLIENT{'logo'}</TD> |
|
||||
<TD ALIGN=\"right\"> |
|
||||
<FONT COLOR=\"$SYSTEM{'HEADERCOLOR'}\" size=2> |
|
||||
<B>$REPORT{'rptdesc'}\ -\ $REPORT{'rptid'}</B><BR> |
|
||||
</FONT> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
&print_report_C_004(); |
|
||||
} else { |
|
||||
print "<CENTER>\n"; |
|
||||
print "Report $FORM{rptno} is not yet available.\n"; |
|
||||
print "</CENTER>\n"; |
|
||||
} |
|
||||
print "</BODY>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed"); |
|
||||
} |
|
||||
|
|
||||
sub show_detail { |
|
||||
print "<HTML>\n"; |
|
||||
if ($REPORT{'rptid'} eq 'ACT-001') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Log Report $FORM{'dbfile'}"); |
|
||||
print "<HEAD>\n<TITLE>$REPORT{'rptid'} - Log File $FORM{'dbfile'}</TITLE>\n</HEAD>\n"; |
|
||||
print "<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
\n"; |
|
||||
print "<H4>$REPORT{'rptid'} - $REPORT{'rptdesc'}</H4><BR>\n"; |
|
||||
if ($FORM{'filter'}!='') { |
|
||||
print "<B>Session $FORM{'filter'}</B><BR>\n"; |
|
||||
@lines = &get_log("sess.$FORM{'filter'}"); |
|
||||
foreach $line (@lines) { |
|
||||
chomp ($line); |
|
||||
print "$line<BR>\n"; |
|
||||
} |
|
||||
print "<HR WIDTH=\"100\%\">\n"; |
|
||||
} |
|
||||
@lines = &get_log($FORM{'dbfile'}); |
|
||||
foreach $line (@lines) { |
|
||||
chomp ($line); |
|
||||
if ($FORM{'filter'}!='') { |
|
||||
if ($line =~ /,$FORM{'filter'},/ ) { |
|
||||
print "$line<BR>\n"; |
|
||||
} |
|
||||
} else { |
|
||||
print "$line<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Log Report $FORM{'dbfile'} completed"); |
|
||||
} elsif ($REPORT{'rptid'} eq 'ACT-002') { |
|
||||
print "<HEAD> |
|
||||
<TITLE>$REPORT{'rptid'} - Test File $FORM{'dbfile'}</TITLE> |
|
||||
<HEAD> |
|
||||
<TITLE>$REPORT{'rptid'} - $REPORT{'rptdesc'}</TITLE> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
function right(e) { |
|
||||
if (navigator.appName == 'Netscape' && (e.which == 3 || e.which == 2)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} else { |
|
||||
if (navigator.appName == 'Microsoft Internet Explorer' && (event.button == 2 || event.button == 3)) { |
|
||||
alert(\"This source and all graphics are proprietary and may not be viewed or copied.\"); |
|
||||
return false; |
|
||||
} |
|
||||
} |
|
||||
return true; |
|
||||
} |
|
||||
document.onmousedown=right; |
|
||||
document.onmouseup=right; |
|
||||
if (document.layers) window.captureEvents(Event.MOUSEDOWN); |
|
||||
if (document.layers) window.captureEvents(Event.MOUSEUP); |
|
||||
window.onmousedown=right; |
|
||||
window.onmouseup=right; |
|
||||
// --> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\"> |
|
||||
\n"; |
|
||||
$msg = ""; |
|
||||
@locations = ( $testpending, $testinprog, $testcomplete); |
|
||||
$trash = join($pathsep, $locations[$FORM{'location'}], $FORM{'dbfile'}); |
|
||||
open (TESTFILE, "<$trash") or $msg="failed"; |
|
||||
if ($msg eq 'failed') { |
|
||||
print "Unable to open file."; |
|
||||
} else { |
|
||||
@lines = <TESTFILE>; |
|
||||
close TESTFILE; |
|
||||
if ($trash =~ /$testinprog/ ) { |
|
||||
print "<A HREF=\"\#terminate\">TERMINATE THIS TEST</A><BR>\n"; |
|
||||
} |
|
||||
foreach $line (@lines) { |
|
||||
chomp ($line); |
|
||||
print "$line<BR>\n"; |
|
||||
} |
|
||||
if ($trash =~ /$testinprog/ ) { |
|
||||
print "<FORM METHOD=POST ACTION=\"$cgiroot/testterm.pl\">\n"; |
|
||||
print "<INPUT TYPE=HIDDEN NAME=\"tid\" VALUE=\"$SESSION{'tid'}\">\n"; |
|
||||
print "<INPUT TYPE=HIDDEN NAME=\"dbfile\" VALUE=\"$FORM{'dbfile'}\">\n"; |
|
||||
print "<A NAME=\"terminate\">Reason for Terminating The Test:</A><BR>\n"; |
|
||||
print "<TEXTAREA NAME=\"reason\" ROWS=\"4\" COLS=\"40\"></TEXTAREA><BR>\n"; |
|
||||
print "<INPUT TYPE=SUBMIT VALUE=\"Terminate Test\">\n"; |
|
||||
print "</FORM>\n"; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
print "<HEAD>\n<TITLE>$REPORT{'rptid'}</TITLE>\n</HEAD>\n"; |
|
||||
print "<BODY>\n"; |
|
||||
print "Report Not Yet Available.<BR>\n"; |
|
||||
} |
|
||||
print "</BODY>\n"; |
|
||||
print "</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub print_report_C_004 { |
|
||||
@trecs = &get_test_list_all(); |
|
||||
@tmptrecs = (); |
|
||||
for (1 .. $#trecs) { |
|
||||
($id, $desc) = split(/&/, $trecs[$_]); |
|
||||
$trecs[$_] = join('&', "$desc", "$id"); |
|
||||
push @tmptrecs, $trecs[$_]; |
|
||||
} |
|
||||
@tmptrecs = sort @tmptrecs; |
|
||||
my $prev = 'nonesuch'; |
|
||||
@trecs = grep($_ ne $prev && (($prev) = $_), @tmptrecs); |
|
||||
for (0 .. $#trecs) { |
|
||||
($desc,$id) = split(/&/, $trecs[$_]); |
|
||||
$testscompleted = CountTestFiles($testcomplete,"all",$id); |
|
||||
$testsinprogress = CountTestFiles($testinprog, "all",$id); |
|
||||
$testspending = CountTestFiles($testpending, "all",$id); |
|
||||
$href="javascript:parmsC004(document.rptform1,\'$id\')\;"; |
|
||||
$tstoption =" <TR> |
|
||||
<TD valign=top><FONT SIZE=2><a href=\"$href\">$id</a></FONT></TD> |
|
||||
<TD valign=top><FONT SIZE=2>$desc</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testscompleted</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testsinprogress</FONT></TD> |
|
||||
<TD align=right valign=top><FONT SIZE=2>$testspending</FONT></TD> |
|
||||
</TR>\n"; |
|
||||
$tstoptions = join('', $tstoptions, $tstoption); |
|
||||
} |
|
||||
print "<CENTER><B>Test/Survey Summary Statistics</B><br> |
|
||||
$finputs |
|
||||
<TABLE cellpadding=1 cellspacing=1 border=0 width=\"100\%\"> |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
<TR> |
|
||||
<TD valign=top><B><FONT SIZE=1>Test ID</FONT></B></TD> |
|
||||
<TD valign=top><B><FONT SIZE=1>Description</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>Cmp</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>InP</FONT></B></TD> |
|
||||
<TD align=right valign=top><B><FONT SIZE=1>Pnd</FONT></B></TD> |
|
||||
</TR> |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
$tstoptions |
|
||||
<TR><TD colspan=5><HR WIDTH=\"100\%\"></TD></TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
} |
|
||||
@ -1,321 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: tadmin.pl,v 1.10 2006/08/21 20:13:44 psims Exp $ |
|
||||
# |
|
||||
# Source File: tadmin.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'sbalib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
|
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
$isregistrar = &get_a_key("cnd.$SESSION{'clid'}", $SESSION{'uid'}, "registrar"); |
|
||||
if ($FORM{'dbop'} eq 'tnew') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Define New Test"); |
|
||||
@lines = &get_template("tdef"); |
|
||||
&test_new_response; |
|
||||
} elsif ($FORM{'dbop'} eq'tdel') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Delete Test $FORM{'tstid'}"); |
|
||||
#hkh 03/04 get date&time stamp - bug#103 |
|
||||
$deltime = &format_date_time("yymmddhhnnss", "2", "0"); |
|
||||
&test_delete_response($SESSION{'clid'}, $FORM{'tstid'}, $deltime); |
|
||||
&test_files_delete($SESSION{'clid'}, $FORM{'tstid'}, $deltime); |
|
||||
&complete_inprog_pending_test_del($SESSION{'clid'}, $FORM{'tstid'}, $deltime); |
|
||||
&show_template("tdefframe"); |
|
||||
} elsif ($FORM{'dbop'} eq 'tupd') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Edit Test $FORM{'tstid'}"); |
|
||||
@lines = &get_template("tdef"); |
|
||||
&test_update_response($SESSION{'clid'}, $FORM{'tstid'}); |
|
||||
} elsif ($FORM{'dbop'} eq 'cnew') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "New Candidate"); |
|
||||
if ($isregistrar eq "Y") { |
|
||||
$SESSION{'registrar'} = "Y"; |
|
||||
} |
|
||||
@lines = &get_template("addcnd"); |
|
||||
&candidate_new_response; |
|
||||
} elsif ($FORM{'dbop'} eq 'cdel') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Delete Candidate $FORM{'cndid'}"); |
|
||||
#hkh 03/04 get date&time stamp - bug#103 |
|
||||
$deltime = &format_date_time("yymmddhhnnss", "2", "0"); |
|
||||
&candidate_delete_response($SESSION{'clid'}, $FORM{'cndid'}, $deltime); |
|
||||
&complete_inprog_pending_cand_test_del($SESSION{'clid'}, $FORM{'cndid'}, $deltime); |
|
||||
$filterbydate = $FORM{'filterbydate'}; |
|
||||
$FORM{'dtl'} = 8; #I have no idea why this must be set, but it needs to be |
|
||||
$FORM{'filterbydate'} = "Y"; |
|
||||
$filterbydate = $FORM{'filterbydate'}; |
|
||||
$day_filter = $FORM{'day_filter'}; |
|
||||
$date_filter = $FORM{'date_filter'}; |
|
||||
$cnd1_filter = $FORM{'cnd1'}; |
|
||||
$cnd2_filter = $FORM{'cnd2'}; |
|
||||
$cnd3_filter = $FORM{'cnd3'}; |
|
||||
$cnd4_filter = $FORM{'cnd4'}; |
|
||||
$CANDIDATE{'registrar'} = $isregistrar; |
|
||||
&show_template("maintcnd"); |
|
||||
} elsif ($FORM{'dbop'} eq 'cupd') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Edit Candidate $FORM{'cndid'}"); |
|
||||
if ($isregistrar eq "Y") { |
|
||||
$SESSION{'registrar'} = "Y"; |
|
||||
} |
|
||||
@lines = &get_template("addcnd"); |
|
||||
&candidate_update_response($SESSION{'clid'}, $FORM{'cndid'}); |
|
||||
} elsif ($FORM{'dbop'} eq 'gnew') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "New Group Registration"); |
|
||||
@lines = &get_template("grpdef"); |
|
||||
&group_new_response; |
|
||||
} elsif ($FORM{'dbop'} eq 'gdel') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Delete Group Registration $FORM{'grpid'}"); |
|
||||
&group_delete_response($SESSION{'clid'}, $FORM{'grpid'}); |
|
||||
$showmessage = "Group $FORM{'grpid'} has been deleted."; |
|
||||
&show_message_with_close($showmessage); |
|
||||
} elsif ($FORM{'dbop'} eq 'gupd') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Edit Group Registration $FORM{'grpid'}"); |
|
||||
@lines = &get_template("grpdef"); |
|
||||
&group_update_response($SESSION{'clid'}, $FORM{'grpid'}); |
|
||||
} else { |
|
||||
&show_illegal_access_warning; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub test_new_response { |
|
||||
$FORM{'newtest'} = "Y"; |
|
||||
$TEST{'seq'} = $FORM{'seq'}; |
|
||||
if ( ! setup_avail_settings(\%TEST ) ) { |
|
||||
&logger::logerr("Unable to setup availability window"); |
|
||||
} |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub candidate_new_response { |
|
||||
$FORM{'new'} = "Y"; |
|
||||
$FORM{'prevenb'} = 0; |
|
||||
$FORM{'nxtenb'} = 0; |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub group_new_response { |
|
||||
$FORM{'new'} = "Y"; |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub test_update_response { |
|
||||
$TEST{'new'} = "N"; |
|
||||
&get_test_profile($_[0], $_[1]); |
|
||||
$SUBJAREA{'subjskillcgt'}=&get_subjskill_cntgrdtbl($SESSION{'clid'}, $TEST{'id'}, ""); |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub candidate_update_response { |
|
||||
my $cndid; |
|
||||
my $prevenb; |
|
||||
my $nxtenb; |
|
||||
$FORM{'new'} = "N"; |
|
||||
($cndid,$prevenb,$nxtenb)=&get_candidate_list_nav($_[0],$_[1],'nop',$FORM{'sortedkey'}); |
|
||||
$FORM{'prevenb'} = $prevenb unless $isregistrar eq 'Y'; |
|
||||
$FORM{'nxtenb'} = $nxtenb unless $isregistrar eq 'Y'; |
|
||||
&get_candidate_profile($_[0], $_[1]); |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub group_update_response { |
|
||||
$FORM{'new'} = "N"; |
|
||||
&get_candidate_profile($_[0], $_[1]); |
|
||||
foreach $line (@lines) { |
|
||||
$line=&xlatline($line); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub test_delete_response { |
|
||||
@trecs = &get_test_list($_[0]); |
|
||||
#hkh 03/04 write test file to recycle dir before deleting test record - bug#103 |
|
||||
$testfile = "tests.$clid"; |
|
||||
$oldfile = join($pathsep, $dataroot, $testfile); |
|
||||
my $newfile = join($pathsep, $recydataroot, "$testfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
|
|
||||
foreach $trec (@trecs) { |
|
||||
chop ($trec); |
|
||||
($id, $trash) = split(/\&/, $trec); |
|
||||
if ($_[1] ne $id) { |
|
||||
push @newtests, $trec; |
|
||||
} |
|
||||
} |
|
||||
@trecs = @newtests; |
|
||||
&save_test_list($_[0]); |
|
||||
} |
|
||||
|
|
||||
#hkh 03/04 write custom/mtx/question/logo etc. to recycle dir before deleting - |
|
||||
# bug#103 |
|
||||
sub test_files_delete { |
|
||||
if ( ! opendir(DIR, $questionroot) ) { |
|
||||
return 0; |
|
||||
} |
|
||||
my $regex = "^$_[1]".'\.'."$_[0]".'(.*)$'; |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
if ( $srcfile =~ /^$_[1].$_[0](.*)$/ ) { |
|
||||
$oldfile = join($pathsep, $questionroot, $srcfile); |
|
||||
my $newfile = join($pathsep, $recyquestionroot, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
# print "$oldfile deleted $! ...<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
# delete logo files |
|
||||
if ( ! opendir(DIR, $testgraphic) ) { |
|
||||
return 0; |
|
||||
} |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
my $regex = "^$_[0]".'\.'."$_[1]".'(.*)$'; |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
if ( $srcfile =~ /^$_[0].$_[1].0(.*)$/ ) { |
|
||||
$oldfile = join($pathsep, $testgraphic, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestgraphic, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
# print "$oldfile deleted $! ...<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
#hkh 03/04 write completed/inprog/pending files for the deleted test to recycle |
|
||||
# directory before deleting - bug#103 |
|
||||
sub complete_inprog_pending_test_del { |
|
||||
opendir(DIR, $testcomplete); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$clid\./ ) { |
|
||||
if (($srcfile =~ /\.$_[1]/) || ($srcfile =~ /\.$_[1].tim/)) { |
|
||||
$oldfile = join($pathsep, $testcomplete, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestcomplete, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
opendir(DIR, $testinprog); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$clid\./ ) { |
|
||||
if (($srcfile =~ /\.$_[1]/) || ($srcfile =~ /\.$_[1].tim/)) { |
|
||||
$oldfile = join($pathsep, $testinprog, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestinprog, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
opendir(DIR, $testpending); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$clid\./ ) { |
|
||||
if (($srcfile =~ /\.$_[1]/) || ($srcfile =~ /\.$_[1].tim/)) { |
|
||||
$oldfile = join($pathsep, $testpending, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestpending, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
|
|
||||
sub candidate_delete_response { |
|
||||
# &remove_pending_tests($_[0], $_[1]); |
|
||||
#hkh 03/04 write candidate file to recycle dir before deleting cand record - bug#103 |
|
||||
$srcfile = "cnd.$_[0]"; |
|
||||
$oldfile = join($pathsep, $dataroot, $srcfile); |
|
||||
my $newfile = join($pathsep, $recydataroot, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
|
|
||||
@crecs = &get_data("cnd.$_[0]"); |
|
||||
$trash = join( $pathsep, $dataroot, "cnd.$_[0]"); |
|
||||
open (TSTFILE, ">$trash"); |
|
||||
foreach $crec (@crecs) { |
|
||||
($clid, $trash) = split(/\&/, $crec); |
|
||||
if ($_[1] ne $clid) { |
|
||||
print TSTFILE "$crec"; |
|
||||
} |
|
||||
} |
|
||||
close TSTFILE; |
|
||||
} |
|
||||
|
|
||||
sub complete_inprog_pending_cand_test_del { |
|
||||
#hkh 03/04 write completed/inprog/pending files for the deleted cand. to recycle |
|
||||
# directory before deleting - bug#103 |
|
||||
opendir(DIR, $testcomplete); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$_[0].$_[1]\./ ) { |
|
||||
$oldfile = join($pathsep, $testcomplete, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestcomplete, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
opendir(DIR, $testinprog); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$_[0].$_[1]\./ ) { |
|
||||
$oldfile = join($pathsep, $testinprog, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestinprog, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
opendir(DIR, $testpending); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir DIR; |
|
||||
foreach $srcfile (@filenames) { |
|
||||
if ($srcfile =~ /^$_[0].$_[1]\./ ) { |
|
||||
$oldfile = join($pathsep, $testpending, $srcfile); |
|
||||
my $newfile = join($pathsep, $recytestpending, "$srcfile.$_[2]"); |
|
||||
cpbin("$oldfile", "$newfile", 1); |
|
||||
$cnt = unlink $oldfile; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
|
|
||||
sub group_delete_response { |
|
||||
# &remove_pending_tests($_[0], $_[1]); |
|
||||
# @crecs = &get_data("cnd.$_[0]"); |
|
||||
# $trash = join( $pathsep, $dataroot, "cnd.$_[0]"); |
|
||||
# open (TSTFILE, ">$trash"); |
|
||||
# foreach $crec (@crecs) { |
|
||||
# ($clid, $trash) = split(/\&/, $crec); |
|
||||
# if ($_[1] ne $clid) { |
|
||||
# print TSTFILE "$crec"; |
|
||||
# } |
|
||||
# } |
|
||||
# close TSTFILE; |
|
||||
} |
|
||||
@ -1,845 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: tdef.pl,v 1.11 2006/05/22 16:06:41 psims Exp $ |
|
||||
# |
|
||||
# Source File: tdef.pl |
|
||||
|
|
||||
# Get config |
|
||||
use CGI qw/:standard/; |
|
||||
|
|
||||
require 'sitecfg.pl'; |
|
||||
require 'ui.pl'; |
|
||||
require 'sbalib.pl'; |
|
||||
|
|
||||
use POSIX; |
|
||||
|
|
||||
if ( ! &go() ) { |
|
||||
&logger::logerr("Unable to successfully serve page"); |
|
||||
} |
|
||||
|
|
||||
sub go { |
|
||||
&app_initialize; |
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
|
|
||||
### DED 8/27/02 Preview CFA |
|
||||
if (($FORM{'cfa'} ne '') && ($FORM{'preview'} eq "Preview")) { |
|
||||
&preview_cfa(); |
|
||||
return; |
|
||||
} |
|
||||
my ($ok, $msg) = &setAvailableDatetimes( \%FORM ); |
|
||||
$FORM{'respmsg'} = ""; |
|
||||
if ( ! $ok ) { |
|
||||
$FORM{'respmsg'} = &errorformat($msg); |
|
||||
$FORM{'savechanges'} = 'N'; |
|
||||
$FORM{'frm'} = 1; |
|
||||
} |
|
||||
if ($FORM{'tstid'} eq '') { $FORM{'tstid'} = $FORM{'id'}; } |
|
||||
if ($FORM{'id'} eq '') { $FORM{'id'} = $FORM{'tstid'}; } |
|
||||
if ($FORM{'UploadImages'} ne '') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Test Image Upload $FORM{'tstid'}"); |
|
||||
&show_upload_form; |
|
||||
return 1; |
|
||||
} else { |
|
||||
if ($FORM{'savechanges'} eq 'Y' ) { |
|
||||
|
|
||||
if ( defined($FORM{'newtest'}) && ($FORM{'newtest'} eq 'Y') && &is_duplicate_test_id($FORM{'tstid'}, $SESSION{'clid'})) { |
|
||||
|
|
||||
# |
|
||||
# Disallow duplicates on new test defns ... |
|
||||
# |
|
||||
$msg = GetLanguageElement($SESSION{lang}, 552); |
|
||||
$msg .= qq{ "$FORM{'tstid'}" (}; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 553); |
|
||||
$msg .= qq{ "$FORM{'desc'}") }; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 554); |
|
||||
$FORM{'respmsg'} .= &errorformat($msg); |
|
||||
&logger::loguerr($msg); |
|
||||
|
|
||||
} elsif ( defined($FORM{'newtest'}) && |
|
||||
($FORM{'newtest'} eq 'Y') && |
|
||||
$FORM{'tstid'} =~ /\s/ ) { |
|
||||
|
|
||||
# |
|
||||
# Disallow spaces in new test IDs ... |
|
||||
# |
|
||||
$msg = GetLanguageElement($SESSION{lang}, 555); |
|
||||
$FORM{'respmsg'} .= &errorformat($msg); |
|
||||
&logger::loguerr($msg); |
|
||||
|
|
||||
} else { |
|
||||
if ($FORM{'flags'} ne '' || $FORM{'group'} ne '' || $FORM{'tstalwrotip'} ne '') { |
|
||||
@flags = split(/\./, $FORM{'flags'}); |
|
||||
$flags[4] = $FORM{'group'}; |
|
||||
$flags[5] = $FORM{'tstalwrotip'}; |
|
||||
$FORM{'flags'} = join('.',@flags); |
|
||||
} |
|
||||
### DED 6/22/04 For Custom fields |
|
||||
### Not yet implemented |
|
||||
#$FORM{'showsubj'} .= ".$FORM{'showques1'}.$FORM{'lblques1'}.$FORM{'showques2'}.$FORM{'lblques2'}"; |
|
||||
|
|
||||
&put_test_profile($SESSION{'clid'}, $FORM{'id'}, \%FORM, $FORM{newtest}); |
|
||||
if ($FORM{'seq'} eq 'std') { |
|
||||
&put_test_saskmatrix($SESSION{'clid'}, $FORM{'id'}, \%FORM); |
|
||||
} |
|
||||
|
|
||||
&put_test_logo($SESSION{'clid'},$FORM{'id'}, \%UPLOADED_FILES); |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Saved Test Definition $FORM{'id'}"); |
|
||||
if ($FORM{'newtest'} eq 'Y') { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Question File Created $FORM{'id'}"); |
|
||||
&create_question_file($SESSION{'clid'}, $FORM{'id'}); |
|
||||
$FORM{'newtest'} = "N"; |
|
||||
} |
|
||||
$FORM{'frm'} = 1; |
|
||||
# $FORM{'respmsg'} .= GetLanguageElement($SESSION{lang}, 556); |
|
||||
|
|
||||
# |
|
||||
# Create an Instance of this test? |
|
||||
# |
|
||||
if ( ($FORM{instanceit} eq 'Y' || $FORM{instanceit} eq 'on') ) { |
|
||||
|
|
||||
$FORM{instancename} = strip_blanks($FORM{instancename}); |
|
||||
$FORM{desc} = $FORM{instancedesc}; |
|
||||
my ($rc, $msg) = &instance_test($SESSION{'clid'}, $FORM{'tstid'}, $FORM{instancename}, \%FORM); |
|
||||
if ( ! $rc ) { |
|
||||
|
|
||||
&logger::logerr("&instance_test($SESSION{'clid'}, $FORM{'tstid'}, $FORM{instancename}) FAILED;"); |
|
||||
#hkh bug#157 delete any new files due to incomplete cloning |
|
||||
} else { |
|
||||
log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", |
|
||||
"Created an Instance of test '$FORM{instancename}' from test/survey '$FORM{'tstid'}'"); |
|
||||
} |
|
||||
$FORM{'respmsg'} .= $msg; |
|
||||
} |
|
||||
|
|
||||
# |
|
||||
# Clone this test? |
|
||||
# |
|
||||
if ( ($FORM{cloneit} eq 'Y' || $FORM{cloneit} eq 'on') ) { |
|
||||
|
|
||||
$FORM{clonename} = strip_blanks($FORM{clonename}); |
|
||||
$FORM{desc} = $FORM{clonedesc}; |
|
||||
my ($rc, $msg) = &clone_test($SESSION{'clid'}, $FORM{'tstid'}, $FORM{clonename}, \%FORM); |
|
||||
if ( ! $rc ) { |
|
||||
|
|
||||
&logger::logerr("&clone_test($SESSION{'clid'}, $FORM{'tstid'}, $FORM{clonename}) FAILED;"); |
|
||||
#hkh bug#157 delete any new files due to incomplete cloning |
|
||||
} else { |
|
||||
log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", |
|
||||
"Cloned test/survey '$FORM{clonename}' from test/survey '$FORM{'tstid'}'"); |
|
||||
} |
|
||||
$FORM{'respmsg'} .= $msg; |
|
||||
} |
|
||||
} |
|
||||
$TEST{'reload'}="Y"; |
|
||||
} else { |
|
||||
$FORM{'respmsg'} .= GetLanguageElement($SESSION{lang}, 557); |
|
||||
} |
|
||||
|
|
||||
push @templates, (tdefund, tdef, tdefstd, tdefadp); |
|
||||
|
|
||||
if ($FORM{'newtest'} ne 'Y') { |
|
||||
&get_test_profile($SESSION{'clid'}, $FORM{'tstid'}); |
|
||||
if ($FORM{'frm'} eq 0) { |
|
||||
$FORM{'frm'} = ($TEST{'seq'} eq 'std') ? 2 : 3; |
|
||||
} |
|
||||
# added for subject area support |
|
||||
} |
|
||||
$SUBJAREA{'subjskillcgt'}=&get_subjskill_cntgrdtbl($SESSION{'clid'}, $FORM{'tstid'}, ""); |
|
||||
# FIXME: This needs to go thru the language support facilities. |
|
||||
if ($FORM{'respmsg'} eq "") { |
|
||||
$FORM{'respmsg'} .= GetLanguageElement($SESSION{lang}, 556); |
|
||||
} |
|
||||
print $FORM{respmsg} if ( $FORM{respmsg} ); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
&show_template($templates[$FORM{'frm'}]); |
|
||||
return 1; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub setAvailableDatetimes { |
|
||||
my ($form) = @_; |
|
||||
|
|
||||
$form->{availonminute} ||= $UI{DEFAULT_AVAILON_MIN}; |
|
||||
$form->{availonhour} ||= $UI{DEFAULT_AVAILON_HR}; |
|
||||
$form->{availthruminute} ||= $UI{DEFAULT_AVAILTHRU_MIN}; |
|
||||
$form->{availthruhour} ||= $UI{DEFAULT_AVAILTHRU_HR}; |
|
||||
|
|
||||
|
|
||||
if ( ! defined($form->{availonminute}) || |
|
||||
! defined($form->{availonhour}) || |
|
||||
! defined($form->{availonpmoffset}) || |
|
||||
! defined($form->{availthruminute}) || |
|
||||
! defined($form->{availthruhour}) || |
|
||||
! defined($form->{availthrupmoffset}) ) { |
|
||||
logger::logerr("One of the 'availon...' or 'availthru...' form fields is undefined...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availonminute} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availonminute' is not of the expected integer format...aborting setAvailableDatetimes(). availonminute = $form->{availonminute}"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availonhour} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availonhour' is not of the expected integer format...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
$form->{availonpmoffset} ||= 0; |
|
||||
$form->{availthrupmoffset} ||= 0; |
|
||||
if ( $form->{availonpmoffset} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availonpmoffset' [$form->{availonpmoffset}] is not of the expected integer format...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availthruminute} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availthruminute' is not of the expected integer format...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availthruhour} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availthruhour' is not of the expected integer format...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availthrupmoffset} !~ /^\d+$/ ) { |
|
||||
logger::logerr("form field 'availthrupmoffset' is not of the expected integer format...aborting setAvailableDatetimes()"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 565)); |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availonhour} < 12 ) { |
|
||||
$form->{availonhour} += $form->{availonpmoffset}; |
|
||||
} elsif ( $form->{availonpmoffset} == 0 ) { |
|
||||
$form->{availonhour} -= 12; |
|
||||
} |
|
||||
|
|
||||
if ( $form->{availthruhour} < 12 ) { |
|
||||
$form->{availthruhour} += $form->{availthrupmoffset}; |
|
||||
} elsif ( $form->{availthrupmoffset} == 0 ) { |
|
||||
$form->{availthruhour} -= 12; |
|
||||
} |
|
||||
|
|
||||
$form->{availon} = sprintf("%02d/%02d/%04d-%02d:%02d", |
|
||||
$form->{availonmonth}, |
|
||||
$form->{availonday}, |
|
||||
$form->{availonyear}, |
|
||||
$form->{availonhour}, |
|
||||
$form->{availonminute}); |
|
||||
|
|
||||
$form->{availthru} = sprintf("%02d/%02d/%04d-%02d:%02d", |
|
||||
$form->{availthrumonth}, |
|
||||
$form->{availthruday}, |
|
||||
$form->{availthruyear}, |
|
||||
$form->{availthruhour}, |
|
||||
$form->{availthruminute}); |
|
||||
|
|
||||
my $on = POSIX::strftime("%s", 0, $form->{availonminute}, |
|
||||
$form->{availonhour}, |
|
||||
$form->{availonday}, |
|
||||
$form->{availonmonth} - 1, |
|
||||
$form->{availonyear} - 1900); |
|
||||
|
|
||||
my $to = POSIX::strftime("%s", 0, $form->{availthruminute}, |
|
||||
$form->{availthruhour}, |
|
||||
$form->{availthruday}, |
|
||||
$form->{availthrumonth} - 1, |
|
||||
$form->{availthruyear} - 1900); |
|
||||
|
|
||||
if ( ! valid_date( $form->{availonyear}, |
|
||||
$form->{availonmonth}, |
|
||||
$form->{availonday}) ) { |
|
||||
&logger::loguerr("Bogus availability start date/time: [$form->{availon}]"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 577)); |
|
||||
} |
|
||||
|
|
||||
if ( ! valid_date( $form->{availthruyear}, |
|
||||
$form->{availthrumonth}, |
|
||||
$form->{availthruday}) ) { |
|
||||
&logger::loguerr("Bogus availability end date/time: [$form->{availthru}]"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 577)); |
|
||||
} |
|
||||
|
|
||||
if ( $to <= $on ) { |
|
||||
&logger::loguerr("Test/survey starting time ($form->{availon}) later than ending time ($form->{availthru})"); |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 576)); |
|
||||
} |
|
||||
|
|
||||
|
|
||||
return (1, ""); |
|
||||
} |
|
||||
|
|
||||
sub valid_test_id_syntax( $ ) { |
|
||||
my ($testid) = @_; |
|
||||
|
|
||||
# No spaces allowed in test names... |
|
||||
if ( $testid =~ /\s/ ) { |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 555)); #No spaces |
|
||||
} |
|
||||
|
|
||||
if ( $testid !~ /\S/ ) { |
|
||||
return (0, GetLanguageElement($SESSION{lang}, 567)); #At least 1 char |
|
||||
} |
|
||||
|
|
||||
return (1, GetLanguageElement($SESSION{lang}, 566)); #OK |
|
||||
} |
|
||||
|
|
||||
# Return 1 if the test already exists, 0 if it does not. |
|
||||
sub is_duplicate_test_id { |
|
||||
($id,$clid) = @_; |
|
||||
|
|
||||
# FIXME: Handle undefined test ID/description |
|
||||
|
|
||||
@test_list = &get_test_list($clid); |
|
||||
|
|
||||
foreach ( @test_list ) { |
|
||||
|
|
||||
($this_id, $this_desc) = split(/&/, $_); |
|
||||
if ( $this_id eq $id ) { |
|
||||
return 1; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return 0; |
|
||||
} |
|
||||
|
|
||||
# |
|
||||
# Copy/duplicate the test $tstid and name the new cloned test $newtestid for |
|
||||
# client $clid. |
|
||||
# |
|
||||
sub instance_test( $ $ $ $ ) { |
|
||||
my ($clid, $oldtestid, $newtestid, $params) = @_; |
|
||||
|
|
||||
my ($rc, $msg) = valid_test_id_syntax($newtestid); |
|
||||
if ( ! $rc ) { |
|
||||
&logger::loguerr("Invalid test ID syntax: '$newtestid'"); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( &is_duplicate_test_id($newtestid, $SESSION{'clid'}) ) { |
|
||||
&logger::loguerr("The test ID '$newtestid' already exists and cannot serve as a test ID for a new instance test for client '$clid'."); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 936); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 564); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 552); |
|
||||
$msg .= qq{ "$newtestid" }; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 554); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! $params || ref($params) ne 'HASH' ) { |
|
||||
&logger::logerr("Missing new test parameters for Instance test ID '$newtestid', client '$clid'."); |
|
||||
return 0; |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 936); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 564); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 565); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my $newtest = 'Y'; |
|
||||
|
|
||||
if ( ! &put_test_profile($clid, $newtestid, $params, $newtest, $oldtestid) ) { |
|
||||
&logger::logerr("put_test_profile($clid,$newtestid,$params,$newtest) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 936); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
if ( ! &link_question_file($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&logger::logerr("link_question_file($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 937); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! &link_sbacustom_files($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&remove_created_question_file($clid, $newtestid); |
|
||||
&logger::logerr("link_sbacustom_files($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 938); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! &link_test_logos($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&remove_created_question_file($clid, $newtestid); |
|
||||
&remove_created_sbacustom_files($clid, $newtestid); |
|
||||
&logger::logerr("link_test_logos($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 939); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 940); |
|
||||
$msg .= "'$oldtestid'"; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 569); |
|
||||
$msg .= "'$newtestid'"; |
|
||||
|
|
||||
return (1, okformat($msg)); |
|
||||
} |
|
||||
|
|
||||
sub link_test_logos { |
|
||||
my ($clid, $srctestid, $newtestid) = @_; |
|
||||
|
|
||||
if ( ! opendir(DIR, $testgraphic) ) { |
|
||||
&logger::logerr("Unable to opendir $testgraphic: $!"); |
|
||||
return 0; |
|
||||
} |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
|
|
||||
# my $regex = "^$clid".'\.'."$srctestid".'(.*)$'; |
|
||||
|
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
|
|
||||
if ( $srcfile =~ /^$clid.$srctestid.0(.*)$/ ) { |
|
||||
my $newfile = join($pathsep, $testgraphic, "$clid.$newtestid.0$1"); |
|
||||
my $oldfile = join($pathsep, $testgraphic, $srcfile); |
|
||||
if (! symlink($oldfile, $newfile)) { |
|
||||
&remove_created_logo_files($clid, $newtestid); |
|
||||
return 0; |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return 1; |
|
||||
} |
|
||||
|
|
||||
sub link_question_file { |
|
||||
my ($clid, $oldtestid, $newtestid) = @_; |
|
||||
my $oldfile = join($pathsep, $questionroot, "$oldtestid.$clid"); |
|
||||
my $newfile = join($pathsep, $questionroot, "$newtestid.$clid"); |
|
||||
if (! symlink($oldfile, $newfile)) { |
|
||||
&remove_created_question_file($clid, $newtestid); |
|
||||
return 0; |
|
||||
} |
|
||||
return 1; |
|
||||
} |
|
||||
|
|
||||
sub link_sbacustom_files { |
|
||||
my ($clid, $oldtestid, $newtestid) = @_; |
|
||||
if ( ! opendir(DIR, $questionroot) ) { |
|
||||
&logger::logerr("Unable to opendir $questionroot: $!"); |
|
||||
return 0; |
|
||||
} |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
|
|
||||
#my $regex = "^$oldtestid".'\.'."$clid".'\.'.'(.*)$'; |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
|
|
||||
if ( $srcfile =~ /^$oldtestid\.$clid\.(.*)$/ ) { |
|
||||
my $newfile = join($pathsep, $questionroot, "$newtestid.$clid.$1"); |
|
||||
my $oldfile = join($pathsep, $questionroot, $srcfile); |
|
||||
if ( ! symlink($oldfile, $newfile)) { |
|
||||
&remove_created_sbacustom_files($clid, $newtestid); |
|
||||
return 0; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return 1; |
|
||||
} |
|
||||
|
|
||||
# |
|
||||
# Copy/duplicate the test $tstid and name the new cloned test $newtestid for |
|
||||
# client $clid. |
|
||||
# |
|
||||
sub clone_test( $ $ $ $ ) { |
|
||||
my ($clid, $oldtestid, $newtestid, $params) = @_; |
|
||||
|
|
||||
my ($rc, $msg) = valid_test_id_syntax($newtestid); |
|
||||
if ( ! $rc ) { |
|
||||
&logger::loguerr("Invalid test ID syntax: '$newtestid'"); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( &is_duplicate_test_id($newtestid, $SESSION{'clid'}) ) { |
|
||||
&logger::loguerr("The test ID '$newtestid' already exists and cannot serve as a test ID for a newly cloned test for client '$clid'."); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 563); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 564); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 552); |
|
||||
$msg .= qq{ "$newtestid" }; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 554); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! $params || ref($params) ne 'HASH' ) { |
|
||||
&logger::logerr("Missing new test parameters for clone test ID '$newtestid', client '$clid'."); |
|
||||
return 0; |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 563); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 564); |
|
||||
$msg .= " ".GetLanguageElement($SESSION{lang}, 565); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
|
|
||||
my $newtest = 'Y'; |
|
||||
|
|
||||
if ( ! &put_test_profile($clid, $newtestid, $params, $newtest) ) { |
|
||||
&logger::logerr("put_test_profile($clid,$newtestid,$params,$newtest) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 563); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! &clone_question_file($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&logger::logerr("clone_question_file($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 731); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
# hkh 01/04 clone mtx & custom files |
|
||||
if ( ! &clone_sbacustom_files($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&remove_created_question_file($clid, $newtestid); |
|
||||
&logger::logerr("clone_sbacustom_files($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 733); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
if ( ! &clone_test_logos($clid, $oldtestid, $newtestid) ) { |
|
||||
&remove_created_test_file($clid, $newtestid); |
|
||||
&remove_created_question_file($clid, $newtestid); |
|
||||
&remove_created_sbacustom_files($clid, $newtestid); |
|
||||
&logger::logerr("clone_test_logos($clid, $oldtestid, $newtestid) FAILED"); |
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 734); |
|
||||
return (0, errorformat($msg)); |
|
||||
} |
|
||||
|
|
||||
my $msg = GetLanguageElement($SESSION{lang}, 568); |
|
||||
$msg .= "'$oldtestid'"; |
|
||||
$msg .= GetLanguageElement($SESSION{lang}, 569); |
|
||||
$msg .= "'$newtestid'"; |
|
||||
|
|
||||
return (1, okformat($msg)); |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub reassignifduplicate { |
|
||||
$vid = $_[1]; |
|
||||
@vtrecs = &get_test_list($_[0]); |
|
||||
while (&test_exists($vid)) { |
|
||||
$vid++; |
|
||||
} |
|
||||
return $vid; |
|
||||
} |
|
||||
|
|
||||
sub put_test_logo { |
|
||||
my ($clid, $testid) = @_; |
|
||||
my $upfile; |
|
||||
my $msg; |
|
||||
my $chmodok; |
|
||||
my $testimg = upload('testimg'); |
|
||||
my @fileparts = split(/\./, param('testimg')); |
|
||||
my $test_logo_ext = $fileparts[$#fileparts]; |
|
||||
@fileparts = (); |
|
||||
if ($SYSTEM{'supportedimagemedia'} =~ /$test_logo_ext/i ) { |
|
||||
@suexts = split(/\;/, $SYSTEM{'supportedimagemedia'}); |
|
||||
# remove any old logos for this test |
|
||||
foreach $suext (@suexts) { |
|
||||
$prefile = join($pathsep, $pubroot, "graphic", "$clid.$testid"); |
|
||||
$existingfile=&file_exists_with_extension($prefile, $suext); |
|
||||
if ($existingfile ne '') { |
|
||||
$cnt = unlink $existingfile; |
|
||||
} |
|
||||
} |
|
||||
# write the uploaded file |
|
||||
$upfile = join($pathsep, $pubroot, "graphic", "$clid.$testid.$test_logo_ext"); |
|
||||
open (OUTFILE, ">$upfile") or $msg="failed"; |
|
||||
if ($msg ne "failed") { |
|
||||
binmode(OUTFILE); |
|
||||
while ($bytesread=read($testimg,$buffer,1024)) { |
|
||||
print OUTFILE $buffer; |
|
||||
} |
|
||||
close OUTFILE; |
|
||||
$chmodok = chmod 0666, $upfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub clone_test_logos { |
|
||||
my ($clid, $srctestid, $newtestid) = @_; |
|
||||
|
|
||||
if ( ! opendir(DIR, $testgraphic) ) { |
|
||||
&logger::logerr("Unable to opendir $testgraphic: $!"); |
|
||||
return 0; |
|
||||
} |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
|
|
||||
# my $regex = "^$clid".'\.'."$srctestid".'(.*)$'; |
|
||||
|
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
|
|
||||
if ( $srcfile =~ /^$clid.$srctestid.0(.*)$/ ) { |
|
||||
my $newfile = join($pathsep, $testgraphic, "$clid.$newtestid.0$1"); |
|
||||
my $oldfile = join($pathsep, $testgraphic, $srcfile); |
|
||||
#hkh bug#58 cpbin("$oldfile", "$newfile", 1); |
|
||||
if (! &get_io_file($oldfile, $newfile)) { |
|
||||
&remove_created_logo_files($clid, $newtestid); |
|
||||
return 0; |
|
||||
} |
|
||||
|
|
||||
# if ( ! cpbin("$oldfile", "$newfile") ) { |
|
||||
# &logger::logerr("cpbin($oldfile, $newfile) FAILED"); |
|
||||
# if ( scalar(@copied) ) { |
|
||||
# &logger::logwarn("DUE cpbin() FAILURE, THERE ARE NOW ORPHANED IMAGE FILES IN $testgraphic: @copied"); |
|
||||
# NOTE: We *could* delete the files we just copied, |
|
||||
# NOTE: but that just seems like a bad idea given |
|
||||
# NOTE: we could end-up deleting some original |
|
||||
# NOTE: graphics files accidentally if they were |
|
||||
# NOTE: already there and thus caused cpbin() to fail. |
|
||||
# } |
|
||||
# return 0; |
|
||||
# } else { |
|
||||
# push( @copied, $newfile ); |
|
||||
# } |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return 1; |
|
||||
} |
|
||||
|
|
||||
sub remove_created_test_file { |
|
||||
my ($clid, $newtestid) = @_; |
|
||||
@trecs = &get_test_list($clid); |
|
||||
foreach $trec (@trecs) { |
|
||||
chop ($trec); |
|
||||
($id, $trash) = split(/\&/, $trec); |
|
||||
if ($newtestid ne $id) { |
|
||||
push @newtests, $trec; |
|
||||
} |
|
||||
} |
|
||||
@trecs = @newtests; |
|
||||
&save_test_list($clid); |
|
||||
} |
|
||||
|
|
||||
#hkh bug#157 delete new logofiles if clonning is not successful |
|
||||
sub remove_created_logo_files { |
|
||||
my ($clid, $newtestid) = @_; |
|
||||
opendir(DIR, $testgraphic); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
if ( $srcfile =~ /^$clid.$newtestid.0(.*)$/ ) { |
|
||||
$ulinkfile = join($pathsep, $testgraphic, $srcfile); |
|
||||
$cnt = unlink $ulinkfile; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub test_exists { |
|
||||
foreach $vtrec (@vtrecs) { |
|
||||
($vid, $vmore) = split(/&/, $vtrec); |
|
||||
if ($vid eq $_[0]) { |
|
||||
return 1; |
|
||||
} |
|
||||
} |
|
||||
return 0; |
|
||||
} |
|
||||
|
|
||||
sub create_question_file { |
|
||||
my ($clid, $testid) = @_; |
|
||||
@lines = &get_question_list("default", "std"); |
|
||||
$trash = join($pathsep, $questionroot, "$testid.$clid"); |
|
||||
open (TMPFILE, ">$trash"); |
|
||||
foreach $line (@lines) { |
|
||||
print TMPFILE "$line"; |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
$chmodok = chmod 0666, $trash; |
|
||||
} |
|
||||
|
|
||||
|
|
||||
sub clone_question_file { |
|
||||
my ($clid, $oldtestid, $newtestid) = @_; |
|
||||
@lines = &get_question_list($oldtestid, $clid); |
|
||||
$new_question_file = join($pathsep, $questionroot, "$newtestid.$clid"); |
|
||||
if ( ! open (TMPFILE, ">$new_question_file") ) { |
|
||||
&logger::logerr("Unable to write to $new_question_file: $!"); |
|
||||
return undef; |
|
||||
} |
|
||||
$line1 = '0'; |
|
||||
foreach $line (@lines) { |
|
||||
#hkh bug#19 if oldtestid is diff. from question-id, replace q-id with newtestid |
|
||||
if ($line1 eq '0') { |
|
||||
$line1 = '1'; |
|
||||
print TMPFILE "$line"; |
|
||||
} else { |
|
||||
@fields = split /&/, $line; |
|
||||
$_ = shift(@fields); |
|
||||
s/.*\./$newtestid./; |
|
||||
unshift(@fields, $_); |
|
||||
$line = join "&", @fields; |
|
||||
#hkh bug#19 $line =~ s/^$oldtestid/$newtestid/; |
|
||||
print TMPFILE "$line"; |
|
||||
} |
|
||||
} |
|
||||
close TMPFILE; |
|
||||
$chmodok = chmod 0666, $new_question_file; |
|
||||
} |
|
||||
|
|
||||
sub remove_created_question_file { |
|
||||
my ($clid, $newtestid) = @_; |
|
||||
$ulinkfile = join($pathsep, $questionroot, "$newtestid.$clid"); |
|
||||
$cnt = unlink $ulinkfile; |
|
||||
} |
|
||||
|
|
||||
# hkh 01/04 |
|
||||
sub clone_sbacustom_files { |
|
||||
my ($clid, $oldtestid, $newtestid) = @_; |
|
||||
if ( ! opendir(DIR, $questionroot) ) { |
|
||||
&logger::logerr("Unable to opendir $questionroot: $!"); |
|
||||
return 0; |
|
||||
} |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
|
|
||||
#my $regex = "^$oldtestid".'\.'."$clid".'\.'.'(.*)$'; |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
|
|
||||
if ( $srcfile =~ /^$oldtestid\.$clid\.(.*)$/ ) { |
|
||||
my $newfile = join($pathsep, $questionroot, "$newtestid.$clid.$1"); |
|
||||
my $oldfile = join($pathsep, $questionroot, $srcfile); |
|
||||
#hkh bug#58 cpbin("$oldfile", "$newfile", 1) |
|
||||
if ( ! &get_io_file($oldfile, $newfile)) { |
|
||||
&remove_created_sbacustom_files($clid, $newtestid); |
|
||||
return 0; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
return 1; |
|
||||
} |
|
||||
|
|
||||
sub remove_created_sbacustom_files { |
|
||||
my ($clid, $newtestid) = @_; |
|
||||
opendir(DIR, $questionroot); |
|
||||
@filenames = readdir(DIR); |
|
||||
closedir(DIR); |
|
||||
foreach my $srcfile ( @filenames ) { |
|
||||
if ( $srcfile =~ /^$newtestid.$clid.(.*)$/ ) { |
|
||||
$ulinkfile = join($pathsep, $questionroot, $srcfile); |
|
||||
$cnt = unlink $ulinkfile; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
} |
|
||||
|
|
||||
sub show_upload_form { |
|
||||
$iShownCount=0; |
|
||||
$qreclist = ""; |
|
||||
&get_test_profile($SESSION{'clid'}, $FORM{'tstid'}); |
|
||||
&show_template("uploadpagehdr"); |
|
||||
print "<FORM METHOD=POST ACTION=\"$PATHS{'cgiroot'}/upimages.pl\" enctype=\"multipart/form-data\">\n"; |
|
||||
print "<input type=hidden name=tid value=\"$SESSION{'tid'}\">\n"; |
|
||||
print "<input type=hidden name=clid value=\"$SESSION{'clid'}\">\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=1 width=\"100%\">\n"; |
|
||||
print "<TR>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "Upload Image\n"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "\ \n"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "Question\n"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "</TR>\n"; |
|
||||
@qrecs = &get_question_list($FORM{'tstid'}, $SESSION{'clid'}); |
|
||||
$bFirst = 1; |
|
||||
foreach $qrec (@qrecs) { |
|
||||
chop ($qrec); |
|
||||
if ($bFirst) { |
|
||||
@flds = split(/&/, $qrec); |
|
||||
$bFirst = 0; |
|
||||
$i = 0; |
|
||||
foreach $fld (@flds) { |
|
||||
if ($fld eq 'qim') { |
|
||||
$iqim = $i; |
|
||||
} else { |
|
||||
if ($fld eq 'id') { |
|
||||
$iid = $i; |
|
||||
} else { |
|
||||
if ($fld eq 'qtx') { |
|
||||
$iqtx = $i; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
$i++; |
|
||||
} |
|
||||
} else { |
|
||||
@flds = split(/&/, $qrec); |
|
||||
if ($flds[$iqim] ne '0') { |
|
||||
$iShownCount++; |
|
||||
print "<TR>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "<INPUT TYPE=FILE NAME=\"$SESSION{'clid'}.$flds[$iid]\" MAXLENGTH=120 SIZE=20> \n"; |
|
||||
$qreclist .= "$flds[$iid]::"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "\ $flds[$iid]:\ \n"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "<TD align=\"left\"><Font Size=1>\n"; |
|
||||
print "$flds[$iqtx]\n"; |
|
||||
print "</font></TD>\n"; |
|
||||
print "</TR>\n"; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
$qreclist = substr($qreclist,0,-2); |
|
||||
unless ($iShownCount) { |
|
||||
print "<TR>\n"; |
|
||||
print "<TD colspan=\"3\" align=\"left\">\n"; |
|
||||
print "No questions were tagged as having images.\n"; |
|
||||
print "</TD>\n"; |
|
||||
print "</TR>\n"; |
|
||||
} |
|
||||
print "<TR>\n"; |
|
||||
print "<TD colspan=\"3\" align=\"center\">\n"; |
|
||||
print "<INPUT TYPE=HIDDEN NAME=\"path\" VALUE=\"$testgraphic\">\n"; |
|
||||
print "<INPUT TYPE=HIDDEN NAME=\"fieldlist\" VALUE=\"$qreclist\">\n"; |
|
||||
print "<INPUT TYPE=SUBMIT VALUE=\"$xlatphrase[512]\">\n"; |
|
||||
print "</TD>\n"; |
|
||||
print "</TR>\n"; |
|
||||
print "</TABLE>\n"; |
|
||||
print "</FORM>\n"; |
|
||||
print "</BODY>\n</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub preview_cfa { |
|
||||
print " |
|
||||
<HTML> |
|
||||
<HEAD> |
|
||||
<!-- Based on agreement.htt,v 1.2 2002/02/14 21:02:55 ed Exp $ --> |
|
||||
<TITLE>Confidentiality Agreement</TITLE> |
|
||||
</HEAD> |
|
||||
<BODY BGCOLOR=\"#FFFFFF\" TEXT=\"#000000\" LINK=\"#0000FF\" VLINK=\"#800080\"> |
|
||||
<TABLE CELLSPACING=0 CELLPADDING=0 BORDER=0 width=\"100%\"> |
|
||||
<TR> |
|
||||
<td align=\"left\"> |
|
||||
<FONT SIZE=4> |
|
||||
<BR> |
|
||||
</FONT> |
|
||||
</td> |
|
||||
</TR> |
|
||||
<TR> |
|
||||
<td align=\"left\"> |
|
||||
$FORM{'cfa'} <BR> |
|
||||
<BR> |
|
||||
</td> |
|
||||
</TR> |
|
||||
<TR> |
|
||||
<td align=\"center\"> |
|
||||
<INPUT TYPE=BUTTON NAME=submit VALUE=\"$xlatphrase[487]\" onClick=window.close()> |
|
||||
<INPUT TYPE=BUTTON NAME=submit VALUE=\"$xlatphrase[488]\" onClick=window.close()> |
|
||||
</form> |
|
||||
</td> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
</BODY> |
|
||||
</HTML>\n"; |
|
||||
} |
|
||||
@ -1,531 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: testdata.pl,v 1.10 2006/11/29 14:44:59 ddoughty Exp $ |
|
||||
# |
|
||||
# Source File: testdata.pl |
|
||||
|
|
||||
# Get config |
|
||||
use FileHandle; |
|
||||
use Reporter; |
|
||||
use Data::Dumper; |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
use strict; |
|
||||
use vars qw(%FORM %SESSION %CLIENT %TEST_SESSION %SUBTEST_QUESTIONS %TEST |
|
||||
%SUBTEST_SUMMARY %CANDIDATE %SUBTEST_ANSWERS %SYSTEM %REPORT |
|
||||
%SUBTEST_RESPONSES); |
|
||||
use vars qw($testcomplete $cgiroot $pathsep $dataroot $testgraphic $graphroot); |
|
||||
|
|
||||
&app_initialize; |
|
||||
&LanguageSupportInit(); |
|
||||
&get_client_profile($SESSION{'clid'}); |
|
||||
|
|
||||
# Make sure we have a valid session, and exit if we don't |
|
||||
if (not &get_session($FORM{'tid'})) { |
|
||||
exit(0); |
|
||||
} |
|
||||
my $options; |
|
||||
|
|
||||
if (exists $FORM{'testid'}) { |
|
||||
@{$options}{qw(showquest displayquest active inactive remediation bysubject subjfilter bydiff difffilter answers)} = |
|
||||
@FORM{qw(showquest displayquest active inactive remediation bysubject subjfilter bydiff difffilter answers)}; |
|
||||
&DisplayQuestions($SESSION{'clid'},$FORM{'testid'},$options); |
|
||||
} else { |
|
||||
&ReportChooser($SESSION{'clid'}); |
|
||||
} |
|
||||
|
|
||||
# There should only be function definitions beyond this point. |
|
||||
exit(0); |
|
||||
|
|
||||
sub ReportChooser { |
|
||||
my ($client) = @_; |
|
||||
print &Reporter::HTMLHeader("Test Data"); |
|
||||
# options to be implemented - |
|
||||
# drop down menu to choose test |
|
||||
# checkbox and text field to choose subset of questions |
|
||||
# remediation checkbox |
|
||||
# show active checkbox |
|
||||
# show inactive checkbox |
|
||||
# filter by subjct multichoice |
|
||||
# filter by difficulty |
|
||||
print "<form name=\"testdatarpt\" action=\"/cgi-bin/creports.pl\" method=\"Post\" target=\"rptwindow\" enctype=\"multipart/form-data\" >\n"; |
|
||||
print "<input type=\"hidden\" name=\"tid\" value=\"$SESSION{'tid'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptno\" value=\"$FORM{'rptno'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptdesc\" value=\"$REPORT{'rptdesc'}\">\n"; |
|
||||
print "<input type=hidden name=\"rptid\" value=\"$REPORT{'rptid'}\">\n"; |
|
||||
|
|
||||
print "<table>\n"; |
|
||||
#print "<tr><th>Test</th><th>Questions</th><th>S |
|
||||
print "<tr valign=\"top\"><td><b>Select Test:</b><br><select name=\"testid\">\n"; |
|
||||
my @tests = &get_test_list($client); |
|
||||
shift @tests; |
|
||||
my (@details,%subjects); |
|
||||
foreach my $testid (@tests) { |
|
||||
my ($id,$desc) = split(/&/,$testid); |
|
||||
print "<option value=\"$id\">$desc</option>\n"; |
|
||||
my $tmp = &get_question_definitions($client,$id); |
|
||||
push @details, $tmp; |
|
||||
@subjects{map($_->{'subj'},@$tmp)} = 1; |
|
||||
} |
|
||||
print "</select></td>"; |
|
||||
print "<td><b>Show Questions:</b><br><input type=\"radio\" name=\"showquest\" value=\"all\" checked>All<br>". |
|
||||
"<input type=\"radio\" name=\"showquest\" value=\"subset\">Subset: <input type=\"text\" name=\"displayquest\"></td>"; |
|
||||
print "<td><b>Display:</b><br><input type=\"checkbox\" name=\"active\" checked>Active Questions<br>". |
|
||||
"<input type=\"checkbox\" name=\"inactive\">Inactive Questions<br>". |
|
||||
"<input type=\"checkbox\" name=\"answers\">Question Answers<br>". |
|
||||
"<input type=\"checkbox\" name=\"remediation\">Remediation<br></td>"; |
|
||||
print "</tr>\n"; |
|
||||
print "</table><table>\n"; |
|
||||
print "<tr><td colspan=\"3\"><b>Filter By:</b></tr>\n"; |
|
||||
#my @subjects = qw(astronomy geology physics); |
|
||||
print "<tr valign=\"top\"><td><input type=\"checkbox\" name=\"bysubject\">Subject:<select name=\"subjfilter\" MULTIPLE>"; |
|
||||
foreach my $subject (sort keys %subjects) { |
|
||||
print "<option value=\"$subject\">$subject</option>\n"; |
|
||||
} |
|
||||
my @difficulties = ([0,'basic'],[1,'intermediate'],[2,'advanced']); |
|
||||
print "</td><td><input type=\"checkbox\" name=\"bydiff\">Difficulty:<select name=\"difffilter\">"; |
|
||||
foreach my $difficulty (@difficulties) { |
|
||||
print "<option value=\"$difficulty->[0]\">$difficulty->[1]</option>\n"; |
|
||||
} |
|
||||
print "</select></td>"; |
|
||||
print "</tr>\n"; |
|
||||
print "</table>\n"; |
|
||||
print "<input type=\"submit\" value=\"Get Test\">\n"; |
|
||||
print &Reporter::HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub DisplayQuestions { |
|
||||
my ($client,$test,$options) = @_; |
|
||||
&get_test_profile($client,$test); |
|
||||
my $details = &get_question_definitions($client,$test); |
|
||||
print &Reporter::HTMLHeaderPlain("Test Data for $TEST{'desc'}"); |
|
||||
print "<h1>Test Data for $TEST{'desc'}</h1>\n"; |
|
||||
print "<form>\n"; |
|
||||
my (@questnum,%subjects,$difficulty); |
|
||||
if ($options->{'showquest'} eq 'subset') { |
|
||||
$options->{'displayquest'} =~ s/\s+//g; #eliminate whitespace |
|
||||
foreach (split(/,/,$options->{'displayquest'})) { |
|
||||
if (/^\d+$/) {$questnum[$_] = 1;} |
|
||||
if (/^(\d+)-$/) {foreach ($1 .. (scalar(@$details)+1)) {$questnum[$_]=1;}} |
|
||||
if (/^-(\d+)$/) {foreach (1 .. $1) {$questnum[$_]=1;}} |
|
||||
if (/^(\d+)-(\d+)$/) {foreach ($1 .. $2) {$questnum[$_]=1;}} |
|
||||
} |
|
||||
} |
|
||||
if ($options->{'bysubject'}) { |
|
||||
%subjects = map(($_=>1),split(/,/,$options->{'subjfilter'})); |
|
||||
} |
|
||||
if ($options->{'bydiff'}) { |
|
||||
$difficulty = $options->{'difffilter'}; |
|
||||
} |
|
||||
my $questcount = 0; |
|
||||
foreach my $question (@$details) { |
|
||||
### DED 7/28/04 Some questions have qil blank; look for !N instead of Y |
|
||||
#if (not (($options->{'active'} and $question->{'qil'} eq 'N') or |
|
||||
# ($options->{'inactive'} and $question->{'qil'} eq 'Y'))) { |
|
||||
if (not (($options->{'active'} and $question->{'qil'} ne 'Y') or |
|
||||
($options->{'inactive'} and $question->{'qil'} eq 'Y'))) { |
|
||||
next; |
|
||||
} |
|
||||
if ($options->{'bysubject'} and not $subjects{$question->{'subj'}}) {next;} |
|
||||
if ($options->{'bydiff'} and ($question->{'skilllevel'} != $options->{'difffilter'})) {next;} |
|
||||
my (undef, $qindex) = split(/\./,$question->{'id'}); |
|
||||
if (($options->{'showquest'} eq 'subset') and not $questnum[$qindex]) {next;} |
|
||||
$questcount++; |
|
||||
if ($question->{'qil'} eq 'Y') { |
|
||||
print "<font color=\"red\"><h3>$question->{'id'} - Inactive</h3></font>\n"; |
|
||||
} else { |
|
||||
print "<h3>$question->{'id'}</h3>\n"; |
|
||||
} |
|
||||
print "Subject: $question->{'subj'}, Skill: ".(qw(basic intermediate advanced))[$question->{'skilllevel'}]. |
|
||||
"<p>\n"; |
|
||||
if ($question->{'qim'}) { |
|
||||
print $question->{'illustration'}."<br>\n"; |
|
||||
} |
|
||||
if ($question->{'qtp'} eq 'tf') { |
|
||||
print formatTF($question,$options); |
|
||||
} elsif ($question->{'qtp'} eq 'esa') { |
|
||||
print formatESA($question,$options); |
|
||||
} elsif ($question->{'qtp'} eq 'nrt') { |
|
||||
print formatNRT($question,$options); |
|
||||
} elsif ($question->{'qtp'} eq 'mch' or $question->{'qtp'} eq 'ord') { |
|
||||
print formatMCHORD($question,$options); |
|
||||
} elsif ($question->{'qtp'} eq 'mcs' or $question->{'qtp'} eq 'mcm') { |
|
||||
print formatMC($question,$options); |
|
||||
} elsif ($question->{'qtp'} eq 'mtx' or $question->{'qtp'} eq 'mtr') { |
|
||||
print formatMT($question,$options); |
|
||||
} else { |
|
||||
#print "<pre>".Dumper($question)."</pre>"; |
|
||||
} |
|
||||
if ($options->{"remediation"}) { |
|
||||
if ($question->{'qrm'}) { |
|
||||
print "Remdiation:<br>\n$question->{'qrm'}<br>\n"; |
|
||||
} else { |
|
||||
print "No Remediation.<br>\n"; |
|
||||
} |
|
||||
} |
|
||||
print "<hr>\n"; |
|
||||
} |
|
||||
print "</form\n"; |
|
||||
if (not $questcount) { |
|
||||
print "<h3>No Matching Questions Found.</h3>\n"; |
|
||||
} |
|
||||
#print "<pre>".Dumper($details,$options)."</pre>"; |
|
||||
print &Reporter::HTMLFooter(); |
|
||||
} |
|
||||
|
|
||||
sub formatTF { |
|
||||
my ($question,$options) = @_; |
|
||||
my ($optTrue,$optFalse) = ('',''); |
|
||||
#my $outline = "<h3>$question->{'id'}</h3>\n"; |
|
||||
my $outline = "$question->{'qtx'}<p>\n"; |
|
||||
if ($options->{'answers'}) { |
|
||||
$optTrue = ($question->{'qca'}=~/(true|yes)/i ? "checked" : "" ); |
|
||||
$optFalse = ($question->{'qca'}=~/(false|no)/i ? "checked" : "" ); |
|
||||
} |
|
||||
my ($true,$false) = ($question->{'qca'}, $question->{'qia'}); |
|
||||
if ($question->{'qca'} !~ /(true|yes)/i) { |
|
||||
($true,$false) = ($false,$true); |
|
||||
} |
|
||||
$outline .= "<input type=\"radio\" name=\"$question->{'id'}\" value=\"$true\" $optTrue>$true<BR>\n"; |
|
||||
$outline .= "<input type=\"radio\" name=\"$question->{'id'}\" value=\"$false\" $optFalse>$false<P>\n"; |
|
||||
return $outline; |
|
||||
} |
|
||||
|
|
||||
sub formatESA { |
|
||||
my ($question,$options) = @_; |
|
||||
my ($tmp); |
|
||||
#my @esaanswers = split(/\n/,$question->{'qca'}); |
|
||||
my $len; |
|
||||
$tmp = "<ul>\n"; |
|
||||
foreach (split(/[;\n]/,$question->{'qca'})) { |
|
||||
$tmp .= "<li>$_</li>\n"; |
|
||||
$len = ($len < length($_)? length($_): $len); |
|
||||
} |
|
||||
$tmp .= "</ul>\n"; |
|
||||
$len += 5; |
|
||||
my $anslist = "<input type=\"text\" name=\"$question->{'id'}\" VALUE=\"\" SIZE=$len>"; |
|
||||
my $qtext = $question->{'qtx'}; |
|
||||
if ($qtext =~ /<box>/ ) { |
|
||||
$qtext =~ s/<box>/$anslist/g; |
|
||||
} else { |
|
||||
$qtext .= "<p>$anslist\n"; |
|
||||
} |
|
||||
my $outline .= "$qtext<p>\n"; |
|
||||
if ($options->{'answers'}) { |
|
||||
$outline .= "Answers:<br>\n"; |
|
||||
$outline .= $tmp; |
|
||||
} |
|
||||
return $outline; |
|
||||
} |
|
||||
|
|
||||
sub formatMCHORD { |
|
||||
my ($question,$options) = @_; |
|
||||
my $tmp = $question->{'qca'}; |
|
||||
$tmp =~ s/\r/\n/g; $tmp =~ s/\n\n/\n/g; |
|
||||
my @ansopt = split(/\n/,$tmp); |
|
||||
$tmp = $question->{'qia'}; |
|
||||
$tmp =~ s/\r/\n/g; $tmp =~ s/\n\n/\n/g; |
|
||||
my @desc = split(/\n/,$tmp); |
|
||||
my @albls = set_answer_labels($question->{'qalb'}); |
|
||||
my $outline = "$question->{'qtx'}<p>\n"; |
|
||||
my $num = (@ansopt > @desc? @ansopt: @desc); |
|
||||
$outline .= "<table>\n"; |
|
||||
my @answers; |
|
||||
if ($options->{'answers'}) {@answers = @albls;} |
|
||||
for (my $i=0; $i<$num; $i++) { |
|
||||
if ($question->{'qtp'} eq 'mch') { |
|
||||
$outline .= "<tr><td align=\"left\"><INPUT TYPE=TEXT SIZE=\"2\" NAME=\"$question->{'id'}.$i\" value=\"$answers[$i]\">". |
|
||||
" $ansopt[$i] </td>"; |
|
||||
$outline .= "<TD align=\"left\" width=80> </TD>"; |
|
||||
$outline .= "<TD align=\"left\"><b>$albls[$i]</b> $desc[$i]</TD></TR>\n"; |
|
||||
} else { |
|
||||
my $answer = ($options->{'answers'}?" value=\"".($i+1)."\"":""); |
|
||||
$outline .= "<tr><td align=\"left\"><INPUT TYPE=TEXT SIZE=\"2\" NAME=\"$question->{'id'}.$i\"$answer>". |
|
||||
" $ansopt[$i] </td>"; |
|
||||
} |
|
||||
$outline .= "</tr>\n"; |
|
||||
} |
|
||||
$outline .= "</table><p>\n"; |
|
||||
return $outline; |
|
||||
} |
|
||||
|
|
||||
sub formatNRT { |
|
||||
my ($question,$options) = @_; |
|
||||
my $outline = "$question->{'qtx'}<p>\n"; |
|
||||
my $nrtmaxlen = $question->{'qca'}; |
|
||||
my $nrtcols = 50; |
|
||||
my $nrtrows = $nrtmaxlen/$nrtcols; |
|
||||
$nrtrows = ($nrtrows > 5) ? 5 : $nrtrows; |
|
||||
$outline .= "<textarea name=\"$question->{'id'}\" ROWS=\"$nrtrows\" COLS=\"$nrtcols\" wrap=\"on\"></TEXTAREA>\n"; |
|
||||
return $outline; |
|
||||
} |
|
||||
|
|
||||
sub formatMC { |
|
||||
my ($question,$options) = @_; |
|
||||
my ($inptyp); |
|
||||
if (($question->{'qtp'} eq 'mcs' ) || ($question->{'qtp'} eq 'mca')) { |
|
||||
$inptyp = "RADIO"; |
|
||||
} elsif ($question->{'qtp'} eq 'mcm' ) { |
|
||||
$inptyp = "CHECKBOX"; |
|
||||
} else{ |
|
||||
return undef; |
|
||||
} |
|
||||
if ($question->{'anslay'} eq "h") { |
|
||||
$inptyp .= ":".$question->{'anslay'}; |
|
||||
} |
|
||||
my @albls = set_answer_labels($question->{'qalb'}); |
|
||||
my $qca = $question->{'qca'}; |
|
||||
$qca =~ s/\r/\n/g; $qca =~ s/\n\n/\n/g; |
|
||||
my %qansopt = map(($_=>{'correct' =>1}), split(/\n/, $qca)); |
|
||||
my $qia = $question->{'qia'}; |
|
||||
$qia =~ s/\r/\n/g; $qia =~ s/\n\n/\n/g; |
|
||||
foreach (split(/\n/, $qia)) {$qansopt{$_}->{'correct'} = 0;} |
|
||||
my @order; |
|
||||
push @order,split(/\n/, $qca), split(/\n/, $qia); |
|
||||
|
|
||||
my $outline="$question->{'qtx'}<p>\n"; |
|
||||
my $iord=0; |
|
||||
foreach (@order) { |
|
||||
my $qans; |
|
||||
if ($question->{'qalb'} ne "x") { |
|
||||
$qansopt{$_}->{'formatted'} = $albls[$iord].") $_"; |
|
||||
} else { |
|
||||
$qansopt{$_}->{'formatted'} = $_; |
|
||||
} |
|
||||
$qansopt{$_}->{'index'} = $iord++; |
|
||||
} |
|
||||
|
|
||||
if ($inptyp eq 'RADIO:h') { |
|
||||
my $colspan = scalar(keys(%qansopt))+2; |
|
||||
$outline = "<TABLE cellspacing=10>\n"; |
|
||||
$outline .= " <TR><TD colspan=$colspan>"; |
|
||||
$outline .= " <TABLE width=100%>\n"; |
|
||||
$outline .= " <TR><TD align=left>$question->{'left_be'}</TD>"; |
|
||||
$outline .= " <TD align=right>$question->{'right_be'}</TD></TR>\n"; |
|
||||
$outline .= " </TABLE>\n"; |
|
||||
$outline .= " </TD></TR>\n"; |
|
||||
$outline .= " <TR><TD> </TD>"; |
|
||||
} |
|
||||
foreach my $qans (@order) { |
|
||||
my $optselected = (($options->{'answers'} and $qansopt{$qans}->{'correct'}) ? "CHECKED" : ""); |
|
||||
if ($inptyp eq 'RADIO') { |
|
||||
$outline .= "<INPUT TYPE=$inptyp NAME=\"$question->{'id'}\" VALUE=\"$qansopt{$qans}->{'index'}\" $optselected>$qansopt{$qans}->{'formatted'}<BR>\n"; |
|
||||
} elsif ($inptyp eq 'RADIO:h') { |
|
||||
$outline .= "<TD align=center><INPUT TYPE=RADIO NAME=\"$question->{'id'}\" VALUE=\"$qansopt{$qans}->{'index'}\" $optselected></TD>"; |
|
||||
} else { |
|
||||
my $akey = "$question->{'id'}.$qansopt{$qans}->{'index'}"; |
|
||||
$outline .= "<INPUT TYPE=$inptyp NAME=\"$akey\" VALUE=\"$qansopt{$qans}->{'index'}\" $optselected>$qansopt{$qans}->{'formatted'}<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
if ($inptyp eq 'RADIO:h') { |
|
||||
$outline .= "<TD> </TD></TR>\n"; |
|
||||
$outline .= " <TR><TD> </TD>"; |
|
||||
foreach my $qans (@order) { |
|
||||
$outline .= "<TD align=center>$qansopt{$qans}->{'formatted'}</TD>"; |
|
||||
} |
|
||||
$outline .= "<TD> </TD></TR>\n"; |
|
||||
$outline .= "</TABLE>\n"; |
|
||||
} |
|
||||
return $outline."<P>\n";; |
|
||||
} |
|
||||
|
|
||||
sub formatMT { |
|
||||
my ($question,$options) = @_; |
|
||||
|
|
||||
my $outline = "$question->{'qtx'}<p>\n"; |
|
||||
# Split qia into row and col headers |
|
||||
my $qia = $question->{'qia'}; |
|
||||
$qia =~ s/\r/\n/g; |
|
||||
$qia =~ s/\n\n/\n/g; |
|
||||
my ($qrowhdr, $qcolhdr) = split(/RC/,$qia); |
|
||||
my @qrowhdr = split(/\n/, $qrowhdr); |
|
||||
my @qcolhdr = split(/\n/, $qcolhdr); |
|
||||
|
|
||||
#@optvalues = split(/\?/, $_[2]); |
|
||||
#shift @optvalues; |
|
||||
my @optvalues = (); |
|
||||
my $i=0; |
|
||||
my @chmatrix; |
|
||||
if ($question->{'qtp'} eq 'mtx') { |
|
||||
# Mark previous selections with "CHECKED" |
|
||||
foreach my $row (0 .. $#qrowhdr) { |
|
||||
foreach my $col (0 .. $#qcolhdr) { |
|
||||
if ($optvalues[$i] != "xxx") { |
|
||||
$chmatrix[$row][$col]="CHECKED"; |
|
||||
} else { |
|
||||
$chmatrix[$row][$col]=""; |
|
||||
} |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
} else { |
|
||||
# Mark previous selections with "SELECTED" |
|
||||
foreach my $row (0 .. $#qrowhdr) { |
|
||||
foreach my $col (0 .. $#qcolhdr) { |
|
||||
my $rank = $optvalues[$i]; |
|
||||
foreach my $irank (0 .. 5) { |
|
||||
if ($irank eq $rank) { |
|
||||
$chmatrix[$i][$irank]="SELECTED"; |
|
||||
} else { |
|
||||
$chmatrix[$i][$irank]=""; |
|
||||
} |
|
||||
} |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
# Build matrix html |
|
||||
$outline="<table border=2>\n<tr><td> </td>"; |
|
||||
foreach (0 .. $#qcolhdr) { |
|
||||
$outline .= "<td>$qcolhdr[$_]</td>"; |
|
||||
} |
|
||||
$outline .= "</tr>\n"; |
|
||||
$i=0; |
|
||||
foreach my $row (0 .. $#qrowhdr) { |
|
||||
$outline .= "<tr><td>$qrowhdr[$row]</td>"; |
|
||||
foreach my $col (0 .. $#qcolhdr) { |
|
||||
if ($question->{'qtp'} eq 'mtx') { |
|
||||
$outline .= "<td align=center><input type=checkbox name=\"qrs$row$col\" value=\"1\" $chmatrix[$row][$col]></td>"; |
|
||||
} else { |
|
||||
$outline .= "<td align=center><select name=\"qrs$row$col\"><option value='' $chmatrix[$i][0]>\ \;</option><option value=1 $chmatrix[$i][1]>1</option><option value=2 $chmatrix[$i][2]>2</option><option value=3 $chmatrix[$i][3]>3</option><option value=4 $chmatrix[$i][4]>4</option><option value=5 $chmatrix[$i][5]>5</option></select></td>"; |
|
||||
} |
|
||||
$i++; |
|
||||
} |
|
||||
$outline .= "</tr>\n"; |
|
||||
} |
|
||||
$outline .= "</table>\n"; |
|
||||
return $outline; |
|
||||
} |
|
||||
|
|
||||
sub get_question_definitions { |
|
||||
my ($clid, $testid) = @_; |
|
||||
my $qcount = 0; |
|
||||
my $questions = []; |
|
||||
my @qrecs = &get_question_list($testid, $clid); |
|
||||
chomp $qrecs[0]; |
|
||||
my @flds = split(/&/,shift(@qrecs)); |
|
||||
foreach my $qrec (@qrecs) { |
|
||||
chomp ($qrec); |
|
||||
#($id, $qtyp) = split(/&/, $qrec); |
|
||||
my @rowdata = split(/&/, $qrec); |
|
||||
my $i=0; |
|
||||
my $question = {}; |
|
||||
@{$question}{@flds} = @rowdata; |
|
||||
($question->{'subj'},$question->{'skilllevel'}) = split(/\./,$question->{'subj'}); |
|
||||
$question->{'tf'} = ($question->{'qtp'} eq 'tf') ? "SELECTED" : ""; |
|
||||
$question->{'mcs'} = ($question->{'qtp'} eq 'mcs') ? "SELECTED" : ""; |
|
||||
$question->{'mcm'} = ($question->{'qtp'} eq 'mcm') ? "SELECTED" : ""; |
|
||||
$question->{'esa'} = ($question->{'qtp'} eq 'esa') ? "SELECTED" : ""; |
|
||||
$question->{'nrt'} = ($question->{'qtp'} eq 'nrt') ? "SELECTED" : ""; |
|
||||
$question->{'qtx'} =~ s/\;/\n/g; |
|
||||
$question->{'qca'} =~ s/\;/\n/g; |
|
||||
$question->{'qia'} =~ s/\;/\n/g; |
|
||||
|
|
||||
$question->{'lbla'} = ($question->{'qalb'} eq 'a') ? "SELECTED" : ""; |
|
||||
$question->{'lblA'} = ($question->{'qalb'} eq 'A') ? "SELECTED" : ""; |
|
||||
$question->{'lbln'} = ($question->{'qalb'} eq 'n') ? "SELECTED" : ""; |
|
||||
$question->{'lblr'} = ($question->{'qalb'} eq 'r') ? "SELECTED" : ""; |
|
||||
$question->{'lblR'} = ($question->{'qalb'} eq 'R') ? "SELECTED" : ""; |
|
||||
|
|
||||
$question->{'tft'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'TRUE') ? "CHECKED" : ""; |
|
||||
$question->{'tff'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'FALSE') ? "CHECKED" : ""; |
|
||||
$question->{'tfy'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq 'YES') ? "CHECKED" : ""; |
|
||||
$question->{'tfn'} = ($question->{'qtp'} eq 'tf' && $question->{'qca'} eq'NO') ? "CHECKED" : ""; |
|
||||
|
|
||||
$question->{'qim0'} = ($question->{'qim'} eq '0') ? "SELECTED" : ""; |
|
||||
$question->{'qim1'} = ""; |
|
||||
$question->{'qim2'} = ""; |
|
||||
my $illus = join($pathsep, $testgraphic, "$clid.$question->{'id'}"); |
|
||||
my $supportedmedia = join(';', $SYSTEM{'supportedimagemedia'}, $SYSTEM{'supportedaudiomedia'}, $SYSTEM{'supportedvideomedia'}); |
|
||||
my $illusfile = &file_exists_with_extension($illus, $supportedmedia); |
|
||||
$question->{'illustration'} = ""; |
|
||||
$question->{'defthumbnail'} = "<IMG NAME=\"qimage\" SRC=\"$graphroot/noimageassigned.gif\" width=100 BORDER=0>"; |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'qim1'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '2') { |
|
||||
$question->{'qim2'} = "SELECTED"; |
|
||||
} elsif ($question->{'qim'} eq '3' ) { |
|
||||
$question->{'qim3'} = "SELECTED"; |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$question->{'flr'}\" TARGET=\"illustrated\">Reference Page</A>"; |
|
||||
} |
|
||||
if ($illusfile ne '') { |
|
||||
my @filesegs = split(/\./, $illusfile); |
|
||||
my $fext = $filesegs[$#filesegs]; |
|
||||
@filesegs = () ; |
|
||||
if ($SYSTEM{'supportedimagemedia'} =~ m/$fext/i ) { |
|
||||
if ($question->{'qim'} eq '1') { |
|
||||
$question->{'illustration'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\">Illustration</A>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} else { |
|
||||
$question->{'illustration'} = "<IMG NAME=\"qimage\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" BORDER=0>"; |
|
||||
$question->{'defthumbnail'} = "<A NAME=\"qimage\" HREF=\"$cgiroot/imagepop.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" TARGET=\"illustrated\"><IMG NAME=\"qimagetn\" SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" width=100 BORDER=0></A>"; |
|
||||
} |
|
||||
} elsif ($SYSTEM{'supportedvideomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" CONTROLS=\"console\" HIDDEN=\"false\">"; |
|
||||
} elsif ($SYSTEM{'supportedaudiomedia'} =~ m/$fext/i ) { |
|
||||
$question->{'illustration'} = "<EMBED SRC=\"$cgiroot/image.pl?tid=$SESSION{'tid'}\&img=$clid.$question->{'id'}.$fext\" AUTOSTART=\"TRUE\" LOOP=\"false\" VOLUME=\"100\" WIDTH=\"100\" HEIGHT=\"50\" CONTROLS=\"small console\" HIDDEN=\"false\">"; |
|
||||
} |
|
||||
} |
|
||||
#if ($question->{'qnxt'} eq '' ) { |
|
||||
#$question->{'qnxt'} = ($qcount < $#qrecs) ? $qcount + 1 : $#qrecs; |
|
||||
#} else { |
|
||||
#if ($question->{'qnxt'} > $#qrecs) { |
|
||||
#$question->{'qnxt'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
#if ($question->{'qprv'} eq '' ) { |
|
||||
#$question->{'qprv'} = ($qcount == 1) ? 1 : $qcount - 1; |
|
||||
#} else { |
|
||||
#if ($question->{'qprv'} > $#qrecs) { |
|
||||
#$question->{'qprv'} = $#qrecs; |
|
||||
#} |
|
||||
#} |
|
||||
$question->{'totdef'} = $#qrecs; |
|
||||
$question->{'chkobs'} = ($question->{'qil'} eq 'Y') ? "CHECKED" : ""; |
|
||||
if ($question->{'qtx'} =~ /:::/) { |
|
||||
($question->{'qtx'}, $question->{'left_be'}, $question->{'right_be'}) = split(/:::/, $question->{'qtx'}); |
|
||||
} |
|
||||
if ($question->{'layout'} =~ /:/) { |
|
||||
($question->{'layout'}, $question->{'anslay'}) = split(/:/, $question->{'layout'}); |
|
||||
$question->{'anslayhchk'} = ($question->{'anslay'} eq 'h') ? "CHECKED" : ""; |
|
||||
} else { |
|
||||
$question->{'anslay'} = ""; |
|
||||
} |
|
||||
$question->{'anslayvchk'} = ($question->{'anslay'} ne 'h') ? "CHECKED" : ""; |
|
||||
$question->{'layout2chk'} = ($question->{'layout'} eq '2') ? "CHECKED" : ""; |
|
||||
$question->{'layout3chk'} = ($question->{'layout'} eq '3') ? "CHECKED" : ""; |
|
||||
$question->{'layout4chk'} = ($question->{'layout'} eq '4') ? "CHECKED" : ""; |
|
||||
$question->{'layout5chk'} = ($question->{'layout'} eq '5') ? "CHECKED" : ""; |
|
||||
$question->{'layout1chk'} = ($question->{'layout'} eq '1') ? "CHECKED" : ""; |
|
||||
if ($question->{'layout'} eq '') { |
|
||||
$question->{'layout'} = '1'; |
|
||||
$question->{'layout1chk'} = "CHECKED"; |
|
||||
} |
|
||||
# sac v start addition for comment input support |
|
||||
my @qflags = split(/\./,$question->{'flags'}); |
|
||||
$question->{'qcmtprmpt'} = $qflags[0]; |
|
||||
$question->{'chkqccmt'} = ($qflags[0] eq 'Y') ? "CHECKED" : ""; |
|
||||
$question->{'qcprmpt'} = ($qflags[0] eq 'Y') ? $qflags[1] : ""; |
|
||||
$question->{'promptcomments'}=""; |
|
||||
if ($qflags[0] eq 'Y') { |
|
||||
$question->{'promptcomments'}=" |
|
||||
<FONT SIZE=\"4\">\ <br> |
|
||||
<b><i>$qflags[1]</i></b><br> |
|
||||
<TEXTAREA NAME=\"qcucmt\" cols=\"50\" rows=\"3\" |
|
||||
wrap=on onKeyPress=\"languagesupport(this)\" |
|
||||
onFocus=\"return tGotFocus(this)\" |
|
||||
onChange=\"return onConvert(this)\"></TEXTAREA> |
|
||||
</FONT><br>\n"; |
|
||||
if (($question->{'layout'} eq '4') || ($question->{'layout'} eq '5') || ($question->{'qtyp'} eq 'nrt')) { |
|
||||
$question->{'promptcomments'}=join('',"\ <br>",$question->{'promptcomments'}); |
|
||||
} else { |
|
||||
$question->{'promptcomments'}=join('',"<tr><td>",$question->{'promptcomments'},"</td></tr>"); |
|
||||
} |
|
||||
} |
|
||||
# sac ^ end addition for comment input support |
|
||||
#return; |
|
||||
push @$questions, $question; |
|
||||
} |
|
||||
return $questions; |
|
||||
} |
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,800 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: tocrinp.pl |
|
||||
# |
|
||||
# Source File: tocrinp.pl |
|
||||
|
|
||||
# Get config |
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
my $show_template = "selectpg"; |
|
||||
&LanguageSupportInit(); |
|
||||
$FORM{'respmsg'} = ""; |
|
||||
if ($FORM{'dbop'} eq 'hc') { |
|
||||
# client selection header frame |
|
||||
$show_template="tocrclient"; |
|
||||
} elsif ($FORM{'dbop'} eq 'ht') { |
|
||||
# test selection header frame |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
$show_template=($FORM{'clid'} eq '') ? "selectpg" : "tocrtest"; |
|
||||
} elsif ($FORM{'dbop'} eq 'hu') { |
|
||||
# candidate selection header frame |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
$FORM{'testcandidates'}=&get_test_candidates($FORM{'clid'},$FORM{'tstid'},$FORM{'unscored'},$FORM{'completed'}); |
|
||||
$FORM{'tccount'}=($FORM{'testcandidates'} eq '') ? 0 : 1; |
|
||||
$show_template=($FORM{'tstid'} eq '') ? "selectpg" : "tocrcnd"; |
|
||||
} elsif ($FORM{'dbop'} eq 'dtl') { |
|
||||
if ($FORM{'cndid'} eq '') { |
|
||||
$show_template="selectpg"; |
|
||||
} else { |
|
||||
my $dir = ($FORM{'unscored'} eq 'P') ? $testpending : $testcomplete; |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
&get_test_profile($FORM{'clid'},$FORM{'tstid'}); |
|
||||
&get_candidate_profile($FORM{'clid'},$FORM{'cndid'}); |
|
||||
&get_test_sequence( $CLIENT{'clid'}, $CANDIDATE{'uid'}, $TEST{'id'}, $dir); |
|
||||
&CreateOCRInputForm(); |
|
||||
$show_template=""; |
|
||||
} |
|
||||
} elsif ($FORM{'dbop'} eq 'post') { |
|
||||
# test replication detail save |
|
||||
if ($FORM{'cndid'} eq '') { |
|
||||
$show_template="selectpg"; |
|
||||
} else { |
|
||||
$endtime = &format_date_time("dd-mmm-yyyy hh:nn:ss GMT", "1", "0"); |
|
||||
my $dir = ($FORM{'unscored'} eq 'P') ? $testpending : $testcomplete; |
|
||||
&get_client_profile($FORM{'clid'}); |
|
||||
&get_test_profile($FORM{'clid'},$FORM{'tstid'}); |
|
||||
&get_candidate_profile($FORM{'clid'},$FORM{'cndid'}); |
|
||||
&get_test_sequence( $CLIENT{'clid'}, $CANDIDATE{'uid'}, $TEST{'id'}, $dir); |
|
||||
&promote_test_sequence( $testpending, $testinprog, $TEST_STATES{'_PENDING'}); |
|
||||
$tetmplt = 'tsubend'; |
|
||||
$tsubtest = 2; |
|
||||
$TEST_SESSION{'subtest'} = $FORM{'tstid'}; |
|
||||
&single_form_test_done($dir); |
|
||||
&make_anonymous(); |
|
||||
$show_template=""; |
|
||||
} |
|
||||
} |
|
||||
unless ($show_template eq '') { &show_template($show_template);} |
|
||||
} else { |
|
||||
&show_illegal_access_warning; |
|
||||
} |
|
||||
|
|
||||
sub get_test_candidates { |
|
||||
my ($clid,$tstid,$unscoredflag,$completedflag) = @_; |
|
||||
my $html=""; |
|
||||
my @cnds=(); |
|
||||
my @recs=(); |
|
||||
my $rec; |
|
||||
my $reclid; |
|
||||
my $recndid; |
|
||||
my $rectst; |
|
||||
if ($unscoredflag ne '') { |
|
||||
opendir (TMPDIR, "$testpending"); |
|
||||
@cnds = readdir(TMPDIR); |
|
||||
closedir TMPDIR; |
|
||||
my @recs=grep( /^$clid\.(.*)\.$tstid/ , @cnds); |
|
||||
@cnds=(); |
|
||||
foreach $rec (@recs) { |
|
||||
($reclid,$recndid,$rectst)=&split_test_filename($rec,$clid,$tstid); |
|
||||
if (($reclid eq $clid) && ($rectst eq $tstid)) { |
|
||||
if (&get_candidate_profile($clid,$recndid)) { |
|
||||
$uniquenml = "$CANDIDATE{'nml'}:$CANDIDATE{'uid'}"; |
|
||||
push(@cndsnml,$uniquenml); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
@scndsnml = sort(@cndsnml); |
|
||||
@cndsnml=(); |
|
||||
foreach $cnml (@scndsnml) { |
|
||||
($trash, $tmpcndid) = split(/:/,$cnml); |
|
||||
if (&get_candidate_profile($clid,$tmpcndid)) { |
|
||||
$html=join('',$html,"<option value=\"P$CANDIDATE{'uid'}\">$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}\n"); |
|
||||
} |
|
||||
} |
|
||||
@scndsnml=(); |
|
||||
@recs=(); |
|
||||
} |
|
||||
if ($completedflag ne '') { |
|
||||
opendir (TMPDIR, "$testcomplete"); |
|
||||
@cnds = readdir(TMPDIR); |
|
||||
closedir TMPDIR; |
|
||||
my @recs=grep( /^$clid\.(.*)\.$tstid/ , @cnds); |
|
||||
@cnds=(); |
|
||||
foreach $rec (@recs) { |
|
||||
($reclid,$recndid,$rectst)=&split_test_filename($rec,$clid,$tstid); |
|
||||
if (($reclid eq $clid) && ($rectst eq $tstid)) { |
|
||||
if (&get_candidate_profile($clid,$recndid)) { |
|
||||
$uniquenml = "$CANDIDATE{'nml'}:$CANDIDATE{'uid'}"; |
|
||||
push(@cndsnml,$uniquenml); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
@scndsnml = sort(@cndsnml); |
|
||||
@cndsnml=(); |
|
||||
foreach $cnml (@scndsnml) { |
|
||||
($trash, $tmpcndid) = split(/:/,$cnml); |
|
||||
if (&get_candidate_profile($clid,$tmpcndid)) { |
|
||||
$html=join('',$html,"<option value=\"C$CANDIDATE{'uid'}\">\*$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}\n"); |
|
||||
} |
|
||||
} |
|
||||
@scndsnml=(); |
|
||||
@recs=(); |
|
||||
} |
|
||||
return $html; |
|
||||
} |
|
||||
|
|
||||
sub CreateOCRInputForm() { |
|
||||
if ($TEST{'seq'} eq 'svy') { |
|
||||
@skilllevel = ( '','','','' ); |
|
||||
$itemdescription = "Survey"; |
|
||||
} else { |
|
||||
@skilllevel = ( 'Basic','Intermediate','Advanced','' ); |
|
||||
$itemdescription = "Test"; |
|
||||
} |
|
||||
|
|
||||
$oshowqid = ($FORM{'showqid'} ne '') ? 1 : 0; |
|
||||
$oshowsubj = ($FORM{'showsubj'} ne '') ? 1 : 0; |
|
||||
$oshowskill = ($FORM{'showskill'} ne '') ? 1 : 0; |
|
||||
$oblackoutthrowoffs = ($FORM{'blackoutthrowoffs'} ne '') ? 1 : 0; |
|
||||
$tcolor=$FORM{'ocrtextcolor'}; |
|
||||
|
|
||||
$printwidth = "100\%"; |
|
||||
$titlewidth = "40\%"; |
|
||||
$titlecolwidth = "30\%"; |
|
||||
$refpage = ($FORM{'showgraphics'} eq 'refpage') ? 1 : 0; |
|
||||
if ($refpage) { |
|
||||
$showgraphics = 1; |
|
||||
} else { |
|
||||
$showgraphics = ($FORM{'showgraphics'} eq 'ON') ? 1 : 0; |
|
||||
} |
|
||||
|
|
||||
$ocrstyle=($FORM{'ocrstyle'} ne '') ? 1 : 0; |
|
||||
if ($ocrstyle) { |
|
||||
$scoreboxwarning = "MARK THE CIRCLES UNDER THE CORRECT ANSWER LABEL FOR EACH QUESTION USING A \#2 LEAD PENCIL ONLY."; |
|
||||
} else { |
|
||||
$printscoreboxes = ($FORM{'showscoreboxes'} ne '') ? 1 : 0; |
|
||||
$scoreboxwarning = ($printscoreboxes) ? "DO NOT MARK BOXES TO THE RIGHT OF THE QUESTION. (FOR SCORING USE ONLY)" : ""; |
|
||||
} |
|
||||
if ($FORM{'showdates'} ne '') { |
|
||||
$testavailabilitydates = "Take On/After:<BR>$TEST{'availon'}<BR>Take On/Before:<BR>$TEST{'availthru'} <BR>\n"; |
|
||||
} else { |
|
||||
$testavailabilitydates = ""; |
|
||||
} |
|
||||
@questions = split(/&/,$SUBTEST_QUESTIONS{2}); |
|
||||
@keyanswers = split(/&/,$SUBTEST_ANSWERS{2}); |
|
||||
$masterid = 1; |
|
||||
|
|
||||
$timed = ($TEST{'tmd'} eq 'Y') ? "Allotted Time: $TEST{'maxtm'} mins" : ""; |
|
||||
$testmasterdir = join($pathsep, $secroot, "tests", "master"); |
|
||||
|
|
||||
# $scoreboxwarning = "MARK THE CIRCLES UNDER THE CORRECT ANSWER LABEL FOR EACH QUESTION USING A \#2 LEAD PENCIL ONLY."; |
|
||||
$scoreboxwarning = ""; |
|
||||
$keyhdr = "ANSWER SHEET"; |
|
||||
&PrintPageHeader(); |
|
||||
&PrintSectionHeader(); |
|
||||
&PrintQuestionsOCR(); |
|
||||
&PrintSection(); |
|
||||
@pagequestions = (); |
|
||||
print "</TABLE>\n"; |
|
||||
print "<input type=submit name=\"recSave\" value=\"Post Data\"><br>\n"; |
|
||||
print "$referencepage\n"; |
|
||||
print "</FORM>\n"; |
|
||||
print "</BODY>\n</HTML>\n"; |
|
||||
} |
|
||||
|
|
||||
sub PrintPageHeader { |
|
||||
my $tdate = &format_date_time("mm/dd/yyyy","2", "-10000", time); |
|
||||
my $scored = ($FORM{'unscored'} eq 'P') ? $xlatphrase[442] : $xlatphrase[11]; |
|
||||
if ($FORM{'unscored'} ne 'P') { |
|
||||
my $qscore=$SUBTEST_SUMMARY{2}; |
|
||||
my @qscores=split(/&/, $qscore); |
|
||||
$qtotal=$qscores[0]+$qscores[1]; |
|
||||
$scored=join(' ',$scored,"<font size=1>$qscores[2]\% ($qscores[0] of $qtotal)</font>"); |
|
||||
} |
|
||||
print "<HTML> |
|
||||
<HEAD> |
|
||||
<SCRIPT language=\"JavaScript\"> |
|
||||
<!-- |
|
||||
function onWdwLoad() { |
|
||||
var hasFocus = null; |
|
||||
|
|
||||
// Determine which form element has focus |
|
||||
FlagFocus(); |
|
||||
|
|
||||
document.tocrform.tdate.focus(); |
|
||||
} |
|
||||
|
|
||||
function FlagFocus(){ |
|
||||
for (var x=0; x<document.tocrform.length; ++x) { |
|
||||
document.tocrform.elements[x].onfocus = function(){ |
|
||||
hasFocus = this; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
function RadioSelect(event) { |
|
||||
var charCode = event.keyCode; |
|
||||
|
|
||||
if (hasFocus.type == \"radio\"){ |
|
||||
if (charCode > 47 && charCode < 58) { |
|
||||
if (document.tocrform.elements[hasFocus.name][charCode - 49] != undefined){ |
|
||||
document.tocrform.elements[hasFocus.name][charCode - 49].checked = true; |
|
||||
NextFocus(); |
|
||||
} |
|
||||
} |
|
||||
else if (charCode > 95 && charCode < 106) { |
|
||||
if (document.tocrform.elements[hasFocus.name][charCode - 97] != undefined){ |
|
||||
document.tocrform.elements[hasFocus.name][charCode - 97].checked = true; |
|
||||
NextFocus(); |
|
||||
} |
|
||||
} |
|
||||
else if (charCode > 64 && charCode < 91) { |
|
||||
if (document.tocrform.elements[hasFocus.name][charCode - 65] != undefined){ |
|
||||
document.tocrform.elements[hasFocus.name][charCode - 65].checked = true; |
|
||||
NextFocus(); |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
function NextFocus() { |
|
||||
var RadioFound = false |
|
||||
|
|
||||
for (var x=0; x<document.tocrform.length; ++x) { |
|
||||
if (document.tocrform.elements[x].name == hasFocus.name){ |
|
||||
RadioFound = true; |
|
||||
} |
|
||||
if ((document.tocrform.elements[x].name != hasFocus.name) && RadioFound) { |
|
||||
document.tocrform.elements[x].focus(); |
|
||||
break; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
window.onload=onWdwLoad; |
|
||||
//--> |
|
||||
</SCRIPT> |
|
||||
</HEAD> |
|
||||
<BODY BACKGROUND=\"$SYSTEM{'BACKGROUND'}\" BGCOLOR=\"$SYSTEM{'BGCOLOR'}\" |
|
||||
TEXT=\"$SYSTEM{'TEXT'}\" LINK=\"$SYSTEM{'LINK'}\" |
|
||||
VLINK=\"$SYSTEM{'VLINK'}\" ALINK=\"$SYSTEM{'ALINK'}\" onKeyUp=\"RadioSelect(event);\"> |
|
||||
<FORM METHOD=POST ACTION=\"$PATHS{'cgiroot'}/tocrinp.pl\" Name=\"tocrform\"> |
|
||||
<INPUT NAME=\"tid\" TYPE=HIDDEN VALUE=\"$SESSION{'tid'}\"> |
|
||||
<INPUT NAME=\"clid\" TYPE=HIDDEN VALUE=\"$FORM{'clid'}\"> |
|
||||
<INPUT NAME=\"tstid\" TYPE=HIDDEN VALUE=\"$FORM{'tstid'}\"> |
|
||||
<INPUT NAME=\"cndid\" TYPE=HIDDEN VALUE=\"$FORM{'cndid'}\"> |
|
||||
<INPUT NAME=\"unscored\" TYPE=HIDDEN VALUE=\"$FORM{'unscored'}\"> |
|
||||
<INPUT NAME=\"completed\" TYPE=HIDDEN VALUE=\"$FORM{'completed'}\"> |
|
||||
<INPUT NAME=\"lang\" TYPE=HIDDEN VALUE=\"$SESSION{'lang'}\"> |
|
||||
<INPUT NAME=\"dbop\" TYPE=HIDDEN VALUE=\"post\"> |
|
||||
<CENTER> |
|
||||
<TABLE cellpadding=0 cellspacing=0 border=1 width=$printwidth $bordercolor> |
|
||||
<TR> |
|
||||
<TD colspan=2 valign=top width=$titlecolwidth> |
|
||||
<font size=2 $textcolor><B> |
|
||||
Test: $CLIENT{'clid'}.$CANDIDATE{'uid'}.$TEST{'id'}<BR> |
|
||||
Questions: $#questions<BR> |
|
||||
</B></font> |
|
||||
</TD> |
|
||||
<TD align=center valign=middle width=$titlewidth> |
|
||||
<font size=4 $textcolor><B>$TEST{'desc'}<BR>$keyhdr</B></font> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
<TABLE cellpadding=0 cellspacing=0 border=0 width=$printwidth $bordercolor> |
|
||||
<TR><TD colspan=5><FONT SIZE=1 $textcolor>\ \;<BR></FONT></TD></TR> |
|
||||
<TR> |
|
||||
<TD align=right valign=middle> |
|
||||
<font $textcolor> |
|
||||
<B>Date:\ \;</B> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD valign=middle> |
|
||||
<B><input type=textbox name=\"tdate\" value=\"$tdate\" size=10></B> |
|
||||
</TD> |
|
||||
<TD valign=middle> |
|
||||
<B>\ \;</B><br> |
|
||||
</TD> |
|
||||
<TD align=right valign=middle> |
|
||||
<font $textcolor> |
|
||||
<B>Name:\ \;</B> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD valign=middle> |
|
||||
<B>$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}</B> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
<TR> |
|
||||
<TD valign=middle> |
|
||||
<font $textcolor> |
|
||||
\ \;<br> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD valign=middle> |
|
||||
<font $textcolor> |
|
||||
<B>$scored</B> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD valign=middle> |
|
||||
<font $textcolor> |
|
||||
\ \;<br> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD align=right valign=middle> |
|
||||
<font $textcolor> |
|
||||
<B>Email:\ \;</B> |
|
||||
</font> |
|
||||
</TD> |
|
||||
<TD align=left valign=middle> |
|
||||
<B><input type=textbox name=\"eml\" size=25 value=\"$CANDIDATE{'eml'}\"></B> |
|
||||
</TD> |
|
||||
</TR> |
|
||||
</TABLE> |
|
||||
"; |
|
||||
} |
|
||||
sub PrintSectionHeader { |
|
||||
my $noq=$#questions; |
|
||||
@ocrcoltbl0=(); |
|
||||
@ocrcoltbl1=(); |
|
||||
@ocrcoltbl2=(); |
|
||||
$ocrcolumns = int($noq/50); |
|
||||
my $vernoq = $ocrcolumns*50; |
|
||||
if ($vernoq != $noq) { |
|
||||
$ocrcolumns++; |
|
||||
} |
|
||||
$ocrtblwidth=510/$ocrcolumns; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=1 width=$printwidth $bordercolor>\n"; |
|
||||
} |
|
||||
|
|
||||
sub PrintSection { |
|
||||
my $i; |
|
||||
print "<TR>\n<TD>\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=$ocrtblwidth $bordercolor>\n"; |
|
||||
for $i (0 .. $#ocrcoltbl0) { |
|
||||
print "$ocrcoltbl0[$i]"; |
|
||||
} |
|
||||
print "</TABLE>\n</TD>\n"; |
|
||||
if ($ocrcolumns > 1) { |
|
||||
print "<TD>\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=$ocrtblwidth $bordercolor>\n"; |
|
||||
for $i (0 .. $#ocrcoltbl1) { |
|
||||
print "$ocrcoltbl1[$i]"; |
|
||||
} |
|
||||
print "</TABLE>\n</TD>\n"; |
|
||||
} |
|
||||
if ($ocrcolumns > 2) { |
|
||||
print "<TD>\n"; |
|
||||
print "<TABLE cellpadding=0 cellspacing=0 border=0 width=$ocrtblwidth $bordercolor>\n"; |
|
||||
for $i (0 .. $#ocrcoltbl2) { |
|
||||
print "$ocrcoltbl2[$i]"; |
|
||||
} |
|
||||
print "</TABLE>\n</TD>\n"; |
|
||||
} |
|
||||
print "<\TR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionsOCR() { |
|
||||
my $trash; |
|
||||
my $r=0; |
|
||||
my $c=0; |
|
||||
my $rowhtml; |
|
||||
my $questionindex; |
|
||||
my $backcolor=""; |
|
||||
$referencepage = ""; |
|
||||
$allowupdate = 0; |
|
||||
$scored = 1; |
|
||||
my $prevanswer=$SUBTEST_RESPONSES{2}; |
|
||||
my @prevanswers=split(/&/, $prevanswer); |
|
||||
$prevanswer=""; |
|
||||
my $qscore=$SUBTEST_SUMMARY{2}; |
|
||||
my @qscores=split(/\//, $qscore); |
|
||||
$qscore=""; |
|
||||
my $etc = ""; |
|
||||
foreach $questionindex (1 .. $#questions) { |
|
||||
&get_question_definition($TEST{'id'},$CLIENT{'clid'},$questions[$questionindex]); |
|
||||
$qtype = $QUESTION{'qtp'}; |
|
||||
$anstype = $QUESTION{'qalb'}; |
|
||||
($qsubj, $sklvl) = split(/\./, $QUESTION{'subj'}); |
|
||||
if ($sklvl eq '') { $sklvl = 3; } |
|
||||
($keyresponse,$kflags) = split(/::/, $keyanswers[$questionindex]); |
|
||||
|
|
||||
$scoreable = 1; |
|
||||
$credit = $noanswertag; |
|
||||
$checked = ""; |
|
||||
$answerkey = ""; |
|
||||
$studentkey = ""; |
|
||||
$qanswermatch = ""; |
|
||||
@txts = (); |
|
||||
$prevanswer = $prevanswers[$questionindex]; |
|
||||
$prevanswer =~ s/\'//; |
|
||||
if ($qscores[$questionindex] eq '') { |
|
||||
$backcolor=""; |
|
||||
} else { |
|
||||
($qscore,$etc) = split(/\./,$qscores[$questionindex]); |
|
||||
$backcolor=($qscore == 0) ? "bgcolor=red" : ""; |
|
||||
} |
|
||||
|
|
||||
if ($qtype eq 'nrt') { |
|
||||
&PrintQuestionNRT($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'tf') { |
|
||||
&PrintQuestionTF($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'esa') { |
|
||||
&PrintQuestionESA($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'mcs') { |
|
||||
&PrintQuestionMCS($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'mcm') { |
|
||||
&PrintQuestionMCM($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'mch') { |
|
||||
&PrintQuestionMCH($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'ord') { |
|
||||
&PrintQuestionORD($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} elsif ($qtype eq 'mtx') { |
|
||||
&PrintQuestionMTX($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
} |
|
||||
$rowhtml = join('',"<TR>","<TD align=center valign=\"top\" width=50 $backcolor><font $textcolor><b>\n"); |
|
||||
$rowhtml = join('',$rowhtml,"$questionindex.\n"); |
|
||||
$rowhtml = join('',$rowhtml,"<!-- $keyresponse -->\n"); |
|
||||
$rowhtml = join('',$rowhtml,"</b></font></TD>\n<TD colspan=2>\n"); |
|
||||
$rowhtml = join('',$rowhtml,"<TABLE cellpadding=0 cellspacing=0 border=0>\n<TR>\n"); |
|
||||
$rowhtml = join('',$rowhtml,$answerkey,"</TR>\n</TABLE>\n</TD>\n</TR>\n"); |
|
||||
$c=int(($questionindex-1) / 50); |
|
||||
$r=(($questionindex-1) % 50); |
|
||||
if ($c == 0) { |
|
||||
push @ocrcoltbl0,$rowhtml; |
|
||||
} elsif ($c==1) { |
|
||||
push @ocrcoltbl1,$rowhtml; |
|
||||
} elsif ($c==2) { |
|
||||
push @ocrcoltbl2,$rowhtml; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionNRT { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
$prevans=unmunge($prevans); |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"<textarea name=\"q$qi-qrs\" rows=10 cols=60>$prevans</textarea>"); |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
$colspan=2; |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionTF { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
$checked=($prevans eq 'TRUE') ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"T"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"<input type=\"radio\" name=\"q$qi-qrs\" value=\"TRUE\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$checked=($prevans eq 'FALSE') ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"F"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"<input type=\"radio\" name=\"q$qi-qrs\" value=\"FALSE\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$colspan=2; |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionESA { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
$answerkey = join('',$answerkey,"<td valign=top width=550><font $textcolor>\n"); |
|
||||
$lenresponse = length($keyresponse) + 4; |
|
||||
if ($keyprint == 1) { |
|
||||
$answerkey = "<input type=text size=$lenresponse value=\"$keyresponse\">"; |
|
||||
} else { |
|
||||
$answerkey = "<input type=text size=$lenresponse value=\"$prevans\">"; |
|
||||
} |
|
||||
$colspan=2; |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionMCS { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevanslong,$prevucmt)=split(/::/,$prvresp); |
|
||||
my @prevansary = split(/\?/,$prevanslong); |
|
||||
foreach (@prevansary) { |
|
||||
if ($_ ne "xxx") { |
|
||||
$prevans=$_; |
|
||||
} |
|
||||
} |
|
||||
if ($ttyp eq 'svy') { |
|
||||
@txts = (); |
|
||||
if ($QUESTION{'qca'} ne '') { |
|
||||
push @txts, $QUESTION{'qca'}; |
|
||||
} |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
foreach $qia (@txts_wro) { |
|
||||
push @txts, $qia; |
|
||||
} |
|
||||
@kans = split(/\?/,$keyresponse); |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
foreach $j (1 .. $#kans) { |
|
||||
$jidx = $j-1; |
|
||||
@indexs = split(/=/, $kans[$j]); |
|
||||
$checked = ("$jidx" eq "$prevans") ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"<input type=\"radio\" name=\"q$qi-qrs\" value=\"$jidx\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"$albls[$jidx]."); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
} |
|
||||
} else { |
|
||||
push @txts, $QUESTION{'qca'}; |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
foreach $qia (@txts_wro) { |
|
||||
push @txts, $qia; |
|
||||
} |
|
||||
@kans = split(/\?/,$keyresponse); |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
foreach $j (1 .. $#kans) { |
|
||||
$jidx = $j-1; |
|
||||
@indexs = split(/=/, $kans[$j]); |
|
||||
$checked = ("$jidx" eq "$prevans") ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>"); |
|
||||
$answerkey = join('',$answerkey,"\ $albls[$jidx]."); |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n<td align=center valign=top width=10><font $textcolor>"); |
|
||||
$answerkey = join('',$answerkey,"<input type=radio name=\"q$qi-qrs\" value=\"$jidx\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
} |
|
||||
} |
|
||||
$colspan=2; |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionMCM { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
if ($ttyp eq 'svy') { |
|
||||
@txts = (); |
|
||||
if ($QUESTION{'qca'} ne '') { |
|
||||
push @txts, $QUESTION{'qca'}; |
|
||||
} |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
foreach $qia (@txts_wro) { |
|
||||
push @txts, $qia; |
|
||||
} |
|
||||
@kans = split(/\?/,$keyresponse); |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
foreach $j (1 .. $#kans) { |
|
||||
$jidx = $j-1; |
|
||||
@indexs = split(/=/, $kans[$j]); |
|
||||
$checked = ("$prevans"=~ /$jidx/) ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"<input type=\"checkbox\" name=\"q$qi-qrs$jidx\" value=\"$jidx\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>\n"); |
|
||||
$answerkey = join('',$answerkey,"$albls[$jidx]."); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
} |
|
||||
} else { |
|
||||
push @txts, $QUESTION{'qca'}; |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
foreach $qia (@txts_wro) { |
|
||||
push @txts, $qia; |
|
||||
} |
|
||||
@kans = split(/\?/,$keyresponse); |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
foreach $j (1 .. $#kans) { |
|
||||
$jidx = $j-1; |
|
||||
@indexs = split(/=/, $kans[$j]); |
|
||||
$checked = ("$prevans"=~ /$jidx/) ? "CHECKED" : ""; |
|
||||
$answerkey = join('',$answerkey,"<td align=center valign=top><font $textcolor>"); |
|
||||
$answerkey = join('',$answerkey,"\ $albls[$jidx]."); |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n<td align=center valign=top width=10><font $textcolor>"); |
|
||||
$answerkey = join('',$answerkey,"<input type=checkbox name=\"q$qi-qrs$jidx\" value=\"$jidx\" $checked>"); |
|
||||
$answerkey = join('',$answerkey,"\ </font></td>\n"); |
|
||||
} |
|
||||
} |
|
||||
$colspan=2; |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionMCH { |
|
||||
#&tutor.009 |
|
||||
#&a.4.3.6.5.7.8.0.1.2::MATCH.0:1:1:0 |
|
||||
#&xxxxxxxxx:: |
|
||||
#/0.ghibadcef.xxxxxxxxx |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
my @prevanss=split(//,$prevans); |
|
||||
for (0 .. $#prevanss) { |
|
||||
$prevanss[$_] =~ s/x//; |
|
||||
} |
|
||||
if ($ttyp eq 'svy') { |
|
||||
@txts = split(/\n/, $QUESTION{'qca'}); |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
@ansopts = split(/\./, $keyresponse); |
|
||||
$ansopt = shift @ansopts; |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
$keyresponse = ""; |
|
||||
for (0 .. $#ansopts) { |
|
||||
$cansord[$ansopts[$_]] = $albls[$_]; |
|
||||
# $qanswermatch = join('',$qanswermatch, "<I>($cansord[$ansopts[$_]]) $txts_wro[$ansopts[$_]]</I><BR>\n"); |
|
||||
} |
|
||||
foreach $cansord (@cansord) { |
|
||||
$keyresponse = join('', $keyresponse, $cansord); |
|
||||
} |
|
||||
for (0 .. $#ansopts) { |
|
||||
$answerkey = join('',$answerkey,"<td valign=top><font $textcolor>\n"); |
|
||||
if ($keyprint == 1) { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$cansord[$_]\"><BR>\n"); |
|
||||
} else { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$prevanss[$_]\"><BR>\n"); |
|
||||
} |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
} |
|
||||
@cansord = (); |
|
||||
} else { |
|
||||
@txts = split(/\n/, $QUESTION{'qca'}); |
|
||||
@txts_wro = split(/\n/, $QUESTION{'qia'}); |
|
||||
@ansopts = split(/\./, $keyresponse); |
|
||||
$trash = shift @ansopts; |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
$keyresponse = ""; |
|
||||
for (0 .. $#ansopts) { |
|
||||
$cansord[$ansopts[$_]] = $albls[$_]; |
|
||||
# $qanswermatch = join('',$qanswermatch, "$cansord[$ansopts[$_]].\ \;\ \;$txts_wro[$ansopts[$_]]<BR>\n"); |
|
||||
} |
|
||||
foreach $cansord (@cansord) { |
|
||||
$keyresponse = join('', $keyresponse, $cansord); |
|
||||
} |
|
||||
for (0 .. $#ansopts) { |
|
||||
$answerkey = join('',$answerkey,"<td valign=top><font $textcolor>\n"); |
|
||||
if ($keyprint == 1) { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=2 value=\"$cansord[$_]\"><BR>\n"); |
|
||||
} else { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=2 value=\"$prevanss[$_]\"><BR>\n"); |
|
||||
} |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
} |
|
||||
@cansord = (); |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub PrintQuestionORD { |
|
||||
#&tutor.010 |
|
||||
#&o.3.4.1.0.2::ORDERED.0:1:1:0 |
|
||||
#&xxxxx:: |
|
||||
#/0.45213.xxxxx |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevans,$prevucmt)=split(/::/,$prvresp); |
|
||||
my @prevanss=split(//,$prevans); |
|
||||
for (0 .. $#prevanss) { |
|
||||
$prevanss[$_] =~ s/x//; |
|
||||
} |
|
||||
if ($ttyp eq 'svy') { |
|
||||
@txts = split(/\n/, $QUESTION{'qca'}); |
|
||||
@ansopts = split(/\./, $keyresponse); |
|
||||
$trash = shift @ansopts; |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
for (0 .. $#ansopts) { |
|
||||
$ansopt = $ansopts[$_]; |
|
||||
$ansopt++; |
|
||||
$answerkey = join('',$answerkey,"<td valign=top><font $textcolor>\n"); |
|
||||
if ($keyprint == 1) { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$ansopt\"><BR>\n"); |
|
||||
} else { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$prevanss[$_]\"><BR>\n"); |
|
||||
} |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
} |
|
||||
} else { |
|
||||
@txts = split(/\n/, $QUESTION{'qca'}); |
|
||||
@ansopts = split(/\./, $keyresponse); |
|
||||
$trash = shift @ansopts; |
|
||||
@albls=&set_answer_labels($anstype); |
|
||||
for (0 .. $#ansopts) { |
|
||||
$ansopt = $ansopts[$_]; |
|
||||
$ansopt++; |
|
||||
$answerkey = join('',$answerkey,"<td valign=top><font $textcolor>\n"); |
|
||||
if ($keyprint == 1) { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$ansopt\"><BR>\n"); |
|
||||
} else { |
|
||||
$answerkey = join('',$answerkey,"<input type=text name=\"q$qi-qrs$jidx\" size=1 value=\"$prevanss[$_]\"><BR>\n"); |
|
||||
} |
|
||||
$answerkey = join('',$answerkey,"</font></td>\n"); |
|
||||
} |
|
||||
} |
|
||||
$colspan=2; |
|
||||
} |
|
||||
|
|
||||
#PrintQuestionMTX($TEST{'seq'},$questionindex,$prevanswer); |
|
||||
sub PrintQuestionMTX { |
|
||||
my ($ttyp,$qi,$prvresp) = @_; |
|
||||
my ($prevanslong,$prevucmt)=split(/::/,$prvresp); |
|
||||
my @optvalues = split(/\?/,$prevanslong); |
|
||||
|
|
||||
# Split qia into row and col headers |
|
||||
$qia = $QUESTION{'qia'}; |
|
||||
$qia =~ s/\r/\n/g; |
|
||||
$qia =~ s/\n\n/\n/g; |
|
||||
@qia = split(/::/, $qia); |
|
||||
if ($qia[0] =~ /\n/) { |
|
||||
@qrowhdr = split(/\n/, $qia[0]); |
|
||||
@qcolhdr = split(/\n/, $qia[3]); |
|
||||
$qrowcount = $qia[1]; |
|
||||
$qcolcount = $qia[2]; |
|
||||
} else { |
|
||||
$qrowcount = $qia[0]; |
|
||||
$qcolcount = $qia[1]; |
|
||||
@qlbllist = split(/\n/, $qia[2]); |
|
||||
} |
|
||||
@qia = (); |
|
||||
|
|
||||
# "CHECKBOX" version |
|
||||
|
|
||||
# Mark previous selections with "CHECKED" |
|
||||
shift @optvalues; |
|
||||
$i=0; |
|
||||
foreach $row (0 .. $qrowcount-1) |
|
||||
{ |
|
||||
foreach $col (0 .. $qcolcount-1) |
|
||||
{ |
|
||||
if ($optvalues[$i] != "xxx") |
|
||||
{ |
|
||||
$chmatrix[$row][$col]="CHECKED"; |
|
||||
} |
|
||||
else |
|
||||
{ |
|
||||
$chmatrix[$row][$col]=""; |
|
||||
} |
|
||||
$i++; |
|
||||
} |
|
||||
} |
|
||||
|
|
||||
# Build matrix html |
|
||||
$outline = "<td align=center valign=top colspan=2>"; |
|
||||
$outline .= "<table border=2>\n"; |
|
||||
if ($#qlbllist == -1) { |
|
||||
$outline .= " <tr>\n <td> </td>"; |
|
||||
foreach (0 .. $#qcolhdr) { |
|
||||
$outline .= "<td>$qcolhdr[$_]</td>"; |
|
||||
} |
|
||||
$outline .= "</tr>\n"; |
|
||||
} |
|
||||
$i=0; |
|
||||
foreach $row (0 .. $qrowcount-1) { |
|
||||
$outline .= "<tr>"; |
|
||||
if ($#qlbllist == -1) { |
|
||||
$outline .= "<td>$qrowhdr[$row]</td>"; |
|
||||
} |
|
||||
foreach $col (0 .. $qcolcount-1) { |
|
||||
if ($#qlbllist == -1) { |
|
||||
$outline .= "<td align=center>"; |
|
||||
} else { |
|
||||
$outline .= "<td>"; |
|
||||
$outline .= "<table border=0 width=100%><tr><td align=left>$qlbllist[$i]</td><td align=right>"; |
|
||||
} |
|
||||
if( $ttyp eq 'svy' || ($ttyp eq 'dmg' && $TEST{'group'} eq 'Y')) { |
|
||||
$outline .= "<input type=checkbox name=\"q$qi-qrs$row$col\" value=\"1\" $chmatrix[$row][$col]>"; |
|
||||
} else { |
|
||||
$outline .= "<input type=checkbox name=\"qrs$row$col\" value=\"1\" $chmatrix[$row][$col]>"; |
|
||||
} |
|
||||
if ($#qlbllist != -1) { |
|
||||
$outline .= "</td></tr></table>"; |
|
||||
} |
|
||||
$outline .= "</td>"; |
|
||||
$i++; |
|
||||
} |
|
||||
$outline .= "</tr>\n"; |
|
||||
} |
|
||||
$outline .= "</table>\n"; |
|
||||
$outline .= "</td>\n"; |
|
||||
@qrowhdr = (); |
|
||||
@qcolhdr = (); |
|
||||
@qlbllist = (); |
|
||||
@chmatrix = (); |
|
||||
|
|
||||
$answerkey = $outline; |
|
||||
$colspan=2; |
|
||||
} |
|
||||
File diff suppressed because it is too large
File diff suppressed because it is too large
@ -1,347 +0,0 @@ |
|||||
#!/usr/bin/perl |
|
||||
# |
|
||||
# $Id: uploadmass.pl,v 1.19 2006/09/11 19:17:18 psims Exp $ |
|
||||
# |
|
||||
# Source File: uploadmass.pl |
|
||||
|
|
||||
# Get config |
|
||||
use Text::ParseWords; |
|
||||
use CGI qw/:standard/; |
|
||||
|
|
||||
require 'sitecfg.pl'; |
|
||||
require 'testlib.pl'; |
|
||||
require 'sbalib.pl'; |
|
||||
|
|
||||
&app_initialize; |
|
||||
|
|
||||
print "Content-Type: text/html\n\n"; |
|
||||
|
|
||||
if (&get_session($FORM{'tid'})) { |
|
||||
&LanguageSupportInit(); |
|
||||
$n=0; |
|
||||
&open_results(); |
|
||||
#if (defined($UPLOADED_FILES{'subjareas.csv'})) { $n++;upload_subjareas();} |
|
||||
#if (defined($UPLOADED_FILES{'tests.csv'})) { $n++;upload_tests();} |
|
||||
#if (defined($UPLOADED_FILES{'questions.csv'})) { $n++;upload_questions();} |
|
||||
#if (defined($UPLOADED_FILES{'cnds.csv'})) { $n++;upload_users();} |
|
||||
#if (defined($UPLOADED_FILES{'groups.csv'})) { $n++;upload_groups();} |
|
||||
#if (defined($UPLOADED_FILES{'customfile'})) { $n++;upload_customfile();} |
|
||||
$cndsfile = upload('cndsfile'); |
|
||||
if (defined($cndsfile)) { $n++;upload_users($cndsfile);} |
|
||||
|
|
||||
$testfile = upload('testfile'); |
|
||||
if (defined($testfile)) { $n++;upload_test($testfile);} |
|
||||
|
|
||||
if ($n==0) { |
|
||||
print "<H1>NO UPLOAD FILES PROVIDED. NOTHING IMPORTED.</H1><BR>\n"; |
|
||||
} |
|
||||
&close_results(); |
|
||||
} |
|
||||
|
|
||||
sub upload_users { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "AD/UU"); |
|
||||
# upload users |
|
||||
my $cndsfile = $_[0]; |
|
||||
print "<H1>Importing USERS:</H1><NOBR><BR>\n"; |
|
||||
|
|
||||
@oldrecs = get_data("cnd.$SESSION{'clid'}"); |
|
||||
$oldrec = $oldrecs[0]; |
|
||||
$oldrec =~ (s/authtests/createdate/); |
|
||||
if ( !($oldrec =~ /createdby/) ) { |
|
||||
$oldrec =~ s/grpid/createdby/; |
|
||||
} |
|
||||
chomp ($oldrec); |
|
||||
@curflds = split(/&/, $oldrec); |
|
||||
for (0 .. $#curflds) { $RECFLDS{$curflds[$_]} = $_;}; |
|
||||
$oldkeyidx = $RECFLDS{'uid'}; |
|
||||
for (1 .. $#oldrecs) { |
|
||||
($ukey, $trash) = split(/&/, $oldrecs[$_]); |
|
||||
$OLDRECS{$ukey} = $trash; |
|
||||
} |
|
||||
$oldrechdr = shift @oldrecs; |
|
||||
$oldrechdr =~ (s/authtests/createdate/); |
|
||||
|
|
||||
@udata = <$cndsfile>; |
|
||||
|
|
||||
$newrechdr = "$udata[0]\n"; |
|
||||
@flds = parse_line(',',0,$udata[0]); |
|
||||
$flds[$#flds] =~ s/\s+$// ; # HBI - Delete whitespace at the end of the last element. |
|
||||
for (0 .. $#flds) { $NEWFLDS{$flds[$_]} = $_;}; |
|
||||
@flds=(); |
|
||||
$uididx = $NEWFLDS{'uid'}; |
|
||||
$nmfidx = $NEWFLDS{'nmf'}; |
|
||||
$nmmidx = $NEWFLDS{'nmm'}; |
|
||||
$nmlidx = $NEWFLDS{'nml'}; |
|
||||
$pwdidx = $NEWFLDS{'pwd'}; |
|
||||
|
|
||||
@duprecs = (); |
|
||||
@badfmts = (); |
|
||||
@illchars = (); |
|
||||
@toolongs = (); |
|
||||
@sortedrecs = (); |
|
||||
|
|
||||
$DEFAULT_FLDS{'authtests'} = time(); #authtests gets set to createdate in &put_candidate_profile(), but we have to set it here so it gets put in the file, so please don't delete this line |
|
||||
$DEFAULT_FLDS{'createdate'} = time(); #This sets createdate for existing cnds. The s/authtests/createdate/ gets done before this |
|
||||
$DEFAULT_FLDS{'grpid'} = ""; |
|
||||
$DEFAULT_FLDS{'createdby'} = "$SESSION{'uid'}"; |
|
||||
$DEFAULT_FLDS{'cnd1'} = ""; |
|
||||
$DEFAULT_FLDS{'cnd2'} = ""; |
|
||||
$DEFAULT_FLDS{'cnd3'} = ""; |
|
||||
$DEFAULT_FLDS{'cnd4'} = ""; |
|
||||
$DEFAULT_FLDS{'grpowner'} = "N"; |
|
||||
my $groups = getGroups($SESSION{'clid'}); |
|
||||
for (1 .. $#udata) { |
|
||||
chomp($udata[$_]); |
|
||||
$udata[$_] =~ s/\r//g; |
|
||||
$udata[$_] =~ tr/'/\\'/d; |
|
||||
@flds = parse_line(',',0,$udata[$_]); |
|
||||
$flds[$#flds] =~ s/\s+$// ; # HBI - Delete whitespace at the end of the last element. |
|
||||
$newkey = $flds[$uididx]; |
|
||||
if ((length($flds[$uididx]) > 50) || (length($flds[$uididx]) < 3)) { |
|
||||
$badrec = "uid: $udata[$_]\n"; |
|
||||
push @toolongs, "$badrec"; |
|
||||
#print STDERR "$udata[$_]\n (".join('|||',@flds).")\n"; |
|
||||
} elsif ((length($flds[$pwdidx]) > 50) || (length($flds[$pwdidx]) < 3)){ |
|
||||
$badrec = "pwd: $udata[$_]\n"; |
|
||||
push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'sal'}]) > 15){ |
|
||||
# $badrec = "sal: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif ((length($flds[$nmfidx]) > 20) || (length($flds[$nmfidx]) < 1)){ |
|
||||
} elsif (length($flds[$nmfidx]) < 1) { |
|
||||
$badrec = "nmf: $udata[$_]\n"; |
|
||||
push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$nmmidx]) > 20){ |
|
||||
# $badrec = "nmm: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif ((length($flds[$nmlidx]) > 20) || (length($flds[$nmlidx]) < 1)){ |
|
||||
} elsif (length($flds[$nmlidx]) < 1) { |
|
||||
$badrec = "nml: $udata[$_]\n"; |
|
||||
push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'adr'}]) > 50){ |
|
||||
# $badrec = "adr: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'cty'}]) > 25){ |
|
||||
# $badrec = "cty: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'ste'}]) > 4){ |
|
||||
# $badrec = "ste: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'pst'}]) > 10){ |
|
||||
# $badrec = "pst: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'ctry'}]) > 4){ |
|
||||
# $badrec = "ctry: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'eml'}]) > 100){ |
|
||||
# $badrec = "eml: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'cnd1'}]) > 16){ |
|
||||
# $badrec = "cnd1: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'cnd2'}]) > 16){ |
|
||||
# $badrec = "cnd2: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
#} elsif (length($flds[$NEWFLDS{'grpid'}]) > 100){ |
|
||||
# $badrec = "grpid: $udata[$_]\n"; |
|
||||
# push @toolongs, "$badrec"; |
|
||||
} else { |
|
||||
# Check for illegal characters |
|
||||
$badrec = ""; |
|
||||
foreach $key (keys %NEWFLDS) { |
|
||||
$trash = $flds[$NEWFLDS{$key}]; |
|
||||
if ($key eq "sal") { |
|
||||
$trash =~ tr/. //d; |
|
||||
} elsif ($key eq "adr") { |
|
||||
$trash =~ tr/\- ,\/.#//d; |
|
||||
} elsif ( ($key eq "nmf") || ($key eq "nml") || ($key eq "cty") || ($key eq "ctry") ) { |
|
||||
$trash =~ tr/\- .'//d; |
|
||||
} elsif ($key eq "nmm") { |
|
||||
$trash =~ tr/. //d; |
|
||||
} elsif ($key eq "pst") { |
|
||||
$trash =~ tr/\- //d; |
|
||||
} elsif (($key eq "eml") || ($key eq "uid") || ($key eq "pwd")) { |
|
||||
$trash =~ tr/\-@.//d; |
|
||||
} elsif ($key eq 'grpid') { |
|
||||
$trash =~ tr/:, //d; |
|
||||
} elsif (($key eq "cnd1") || ($key eq "cnd2") || ($key eq "cnd3") || ($key eq "cnd4")) { |
|
||||
$trash =~ tr/ //d; |
|
||||
} |
|
||||
if ( $trash =~ /\W/ ) { |
|
||||
$badrec = "$key: $udata[$_]\n"; |
|
||||
#print STDERR "$key ($flds[$NEWFLDS{$key}],$trash)\n"; |
|
||||
push @illchars, "$badrec"; |
|
||||
} |
|
||||
} |
|
||||
# No illegal chars, so must be good |
|
||||
if ($badrec eq "") { |
|
||||
$goodrec = ""; |
|
||||
if ($OLDRECS{$newkey} eq '') { |
|
||||
for (0 .. $#curflds) { |
|
||||
$delem = ""; |
|
||||
$keyword=$curflds[$_]; |
|
||||
$jidx = $NEWFLDS{$keyword}; |
|
||||
if ($jidx ne '') { |
|
||||
$delem = $flds[$jidx]; |
|
||||
} |
|
||||
if ($delem eq '') { |
|
||||
$delem = $DEFAULT_FLDS{$keyword}; |
|
||||
} |
|
||||
if ($goodrec eq '') { |
|
||||
$goodrec = $delem; |
|
||||
} else { |
|
||||
$goodrec = join('&', $goodrec, $delem); |
|
||||
} |
|
||||
} |
|
||||
push @oldrecs, "$goodrec\n"; |
|
||||
my ($ukey, $trash) = split(/&/, $goodrec); |
|
||||
$OLDRECS{$ukey} = $trash; |
|
||||
} else { |
|
||||
$badrec = "$udata[$_]\n"; |
|
||||
push @duprecs, "$badrec"; |
|
||||
} |
|
||||
if ($flds[$NEWFLDS{'grpid'}]) { |
|
||||
# The are default group assignments |
|
||||
#print STDERR $flds[$NEWFLDS{'grpid'}]."\n"; |
|
||||
foreach my $grp (split(/\s*::\s*/,$flds[$NEWFLDS{'grpid'}])) { |
|
||||
if (not exists $groups->{$grp}) { |
|
||||
$groups->{$grp}->{'grpowner'} = 'grpadmin'; |
|
||||
$groups->{$grp}->{'grpid'} = $grp; |
|
||||
$groups->{$grp}->{'grpnme'} = $grp; |
|
||||
$groups->{$grp}->{'grplist'} = [$flds[$uididx]]; |
|
||||
$groups->{$grp}->{'validfrom'} = '01-01-2000'; |
|
||||
$groups->{$grp}->{'validto'} = '12-31-2037'; |
|
||||
} else { |
|
||||
push @{$groups->{$grp}->{'grplist'}}, $flds[$uididx]; |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
} |
|
||||
@udata = (); |
|
||||
unless($#duprecs eq -1) { |
|
||||
# duplicate, but add any groups the user may not already be a memeber of |
|
||||
print "<B>Rejected: Duplicate user</B> (Group memeberships are added, though)<BR>\n"; |
|
||||
print "$newrechdr<BR>\n"; |
|
||||
for (0 .. $#duprecs) { |
|
||||
print "$duprecs[$_]<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
@duprecs = (); |
|
||||
#unless($#badfmts eq -1) { |
|
||||
#print "<B>Rejected: Required Element(s) Missing</B><BR>\n"; |
|
||||
#print "$newrechdr<BR>\n"; |
|
||||
#for (0 .. $#badfmts) { |
|
||||
#print "$badfmts[$_]<BR>\n"; |
|
||||
#} |
|
||||
#} |
|
||||
unless($#toolongs eq -1) { |
|
||||
print "<B>Rejected: Field Is Wrong Length</B><BR>\n"; |
|
||||
print "$newrechdr<BR>\n"; |
|
||||
for (0 .. $#toolongs) { |
|
||||
print "$toolongs[$_]<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
unless($#illchars eq -1) { |
|
||||
print "<B>Rejected: Illegal Characters</B><BR>\n"; |
|
||||
print "$newrechdr<BR>\n"; |
|
||||
for (0 .. $#illchars) { |
|
||||
print "$illchars[$_]<BR>\n"; |
|
||||
} |
|
||||
} |
|
||||
@badfmts = (); |
|
||||
@toolongs = (); |
|
||||
@illchars = (); |
|
||||
@sortedrecs = sort @oldrecs; |
|
||||
@oldrecs=(); |
|
||||
print "<B>Accepted and Existing:</B><BR>\n"; |
|
||||
print "$oldrechdr<BR>\n"; |
|
||||
$tmpfile = join($pathsep, $dataroot, "cnd.$SESSION{'clid'}"); |
|
||||
open (TMPFILE, ">$tmpfile") or $msg="failed"; |
|
||||
print TMPFILE "$oldrechdr"; |
|
||||
for (0 .. $#sortedrecs) { |
|
||||
print TMPFILE "$sortedrecs[$_]"; |
|
||||
print "$sortedrecs[$_]<BR>\n"; |
|
||||
}; |
|
||||
close TMPFILE; |
|
||||
if ($groups) { |
|
||||
my @newgrps; |
|
||||
#print STDERR Dumper($groups); |
|
||||
foreach my $grp (sort keys (%$groups)) { |
|
||||
push @newgrps, "$grp<br>\n"; |
|
||||
# make entries unique, and sort for good measure |
|
||||
my %tmp = map(($_=>1),@{$groups{$grp}->{'grplist'}}); |
|
||||
@{$groups{$grp}->{'grplist'}} = keys %tmp; |
|
||||
} |
|
||||
if (&setGroups($SESSION{'clid'},$groups)) { |
|
||||
print "<B>Created and Populated Groups:</B><BR>\n@newgrps"; |
|
||||
} else { |
|
||||
print "<B>***Failed*** to Create and Populate Groups:</B><BR>\n"; |
|
||||
} |
|
||||
} else { |
|
||||
print "<B>No Groups Defined:</B><BR>\n"; |
|
||||
} |
|
||||
print "</NOBR><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub upload_groups { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "AD/UG"); |
|
||||
# upload groups |
|
||||
print "<H1>Importing GROUPS:</H1><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub upload_test { |
|
||||
# upload test file |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "AD/UT"); |
|
||||
my $testfile = $_[0]; |
|
||||
|
|
||||
# some browsers send path info - gotta remove it |
|
||||
my $testfilename = param('testfile'); |
|
||||
$testfilename =~ s/\//;/g; |
|
||||
$testfilename =~ s/\\/;/g; |
|
||||
@testfilepath = split(/;/, $testfilename); |
|
||||
$testfilename = $testfilepath[$#testfilepath]; |
|
||||
|
|
||||
# make sure client id is in test file name |
|
||||
if ($testfilename =~ /.$SESSION{'clid'}$/ || $testfilename =~ /.$SESSION{'clid'}./) { |
|
||||
print "<H1>Importing Test file: $testfilename...</H1><BR>\n"; |
|
||||
my $writefile = join($pathsep, $questionroot, $testfilename); |
|
||||
open (OUTFILE,">$writefile"); |
|
||||
while (<$testfile>) { |
|
||||
print OUTFILE $_; |
|
||||
} |
|
||||
close(OUTFILE); |
|
||||
print "<H1>Done.</H1><BR>\n"; |
|
||||
} else { |
|
||||
print "<H1>Test file: $testfilename does not contain proper client id \"$SESSION{'clid'}\".</H1><BR>\n"; |
|
||||
|
|
||||
} |
|
||||
} |
|
||||
|
|
||||
sub upload_questions { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "AD/UQ"); |
|
||||
# upload questions |
|
||||
print "<H1>Importing QUESTIONS:</H1><BR>\n"; |
|
||||
} |
|
||||
|
|
||||
sub upload_subjareas { |
|
||||
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "AD/US"); |
|
||||
# upload subject areas |
|
||||
print "<H1>Importing SUBJECT AREAS:</H1><BR>\n"; |
|
||||
|
|
||||
|
|
||||
} |
|
||||
|
|
||||
sub open_results { |
|
||||
print "<HTML> |
|
||||
<BODY> |
|
||||
"; |
|
||||
} |
|
||||
|
|
||||
sub close_results { |
|
||||
print " |
|
||||
</BODY> |
|
||||
</HTML> |
|
||||
"; |
|
||||
} |
|
||||
@ -1,14 +1,15 @@ |
|||||
useragent=Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:128.0) Gecko/20100101 Firefox/128.0 |
browserversion=5 |
||||
referer=https://vote.x4c.network/cgi-bin/visitor.pl |
loggedout=1721553263 |
||||
browserapp=NSNV |
uac=gadmin |
||||
temptime=1721552655 |
|
||||
lastaccess=1721552656 |
|
||||
tid=17215526550866 |
|
||||
lang=enu |
lang=enu |
||||
clid=std |
lastaccess=1721553263 |
||||
|
temptime=1721552655 |
||||
loggedin=1721552655 |
loggedin=1721552655 |
||||
uid=root1 |
referer=https://vote.x4c.network/cgi-bin/visitor.pl |
||||
home=root |
clid=std |
||||
|
useragent=Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:128.0) Gecko/20100101 Firefox/128.0 |
||||
ipaddr=49.150.106.90 |
ipaddr=49.150.106.90 |
||||
browserversion=5 |
home=root |
||||
uac=gadmin |
browserapp=NSNV |
||||
|
uid=root1 |
||||
|
tid=17215526550866 |
||||
|
|||||
Loading…
Reference in new issue