#!/usr/bin/perl
use strict;
use CGI;
my $ConfigHashRef = 0;
sub GetDBSettings {
my $settings = {};
#----------------------------------------------------------
#Set database settings here
#----------------------------------------------------------
$settings->{"database_type"} = "mysql"; #ODBC (for MS SQL) or mysql (for MySQL)
$settings->{"database_name"} = "SampleDB";
$settings->{"database_username"} = "root";
$settings->{"database_password"} = "password2";
$settings->{"database_address"} = "db"; #127.0.0.1 if on local machine
$settings->{"database_port"} = ""; #Optional. You can leave this blank
$settings->{"studyname"} = ""; #Optional. Specify the study name to have the option to download database tables. See DownloadDatabase() below.
#----------------------------------------------------------
return $settings;
}
sub GetDBSettingsFromEnvVariables {
my $settings = {};
$settings->{"database_type"} = $ENV{"SSI_DATABASE_TYPE"};
$settings->{"database_name"} = $ENV{"SSI_DATABASE_NAME"};
$settings->{"database_username"} = $ENV{"SSI_DATABASE_USERNAME"};
$settings->{"database_password"} = $ENV{"SSI_DATABASE_PASSWORD"};
$settings->{"database_address"} = $ENV{"SSI_DATABASE_ADDRESS"};
$settings->{"database_port"} = $ENV{"SSI_DATABASE_PORT"};
$settings->{"studyname"} = $ENV{"SSI_STUDYNAME"};
return $settings;
}
my $query = CGI->new;
my $intDownload = $query->param("download");
my $blnUseEnvVariables = $query->param("use_env");
if($blnUseEnvVariables){
$ConfigHashRef = GetDBSettingsFromEnvVariables();
}
else{
$ConfigHashRef = GetDBSettings();
}
my $DB = 0;
my ($blnSuccess, $strSimpleError, $strSystemError) = ConnectToDatabase($ConfigHashRef);
if ($intDownload)
{
if ($ConfigHashRef->{"studyname"})
{
DownloadDatabase();
exit();
}
else
{
print "Content-type: text/html\r\n\r\n";
print "No studyname specified.";
exit();
}
}
print "Content-type: text/html\r\n\r\n";
print "";
print "Survey Self-Hosting Database Test";
print "";
print "Survey Self-Hosting Test #2";
print "";
print "";
print "Survey Self-Hosting Database Test
";
print "
";
print "| Result: | ";
if ($blnSuccess)
{
print "Success! Perl is able to connect to the database. | ";
print "
";
}
else
{
print "Error. Perl could not connect to the database. | ";
print "";
if ($strSimpleError)
{
print "The perl script encountered an error: ";
print "
" . $strSimpleError . "
";
print "
Error Details: ";
print "
" . $strSystemError . "
";
print "";
}
}
print "
Perl Database Driver Information
" . PrintDBDriverInfo();
if ($ConfigHashRef->{"studyname"})
{
print "";
}
sub ShowEnvVariables {
print "
Connecting Using Environment Variables
| Environment Variable | Value |
|---|
";
my @envVariables = (
"SSI_DATABASE_TYPE",
"SSI_DATABASE_ADDRESS",
"SSI_DATABASE_NAME",
"SSI_DATABASE_USERNAME",
"SSI_DATABASE_PASSWORD",
"SSI_DATABASE_PORT",
"SSI_DATABASE_DRIVER",
"SSI_DATABASE_MAX_FIELDS_TABLE",
"SSI_RESPNUM_START",
);
foreach my $varName (@envVariables)
{
my $value = $ENV{$varName} || "";
print "| $varName | ";
print (($varName eq "SSI_DATABASE_PASSWORD")? ($value? "******": ""): "$value");
print " |
";
}
print "
";
}
print "WARNING: Make sure to remove this script off the server after you are finished testing.
\n";
if($blnUseEnvVariables){
ShowEnvVariables();
}
print "";
#----------------------------------------------
#
#----------------------------------------------
sub ConnectToDatabase
{
my ($ConfigHashRef) = @_;
my $blnSuccess = 0;
my $blnError = 0;
my $strSystemError = "";
my $strSimpleError = "";
my $strConnectInfo = "";
if(!$ConfigHashRef || !$ConfigHashRef->{"database_password"}){
$blnError = 1;
$strSystemError = "No database settings found.";
$strSimpleError = "Failed to connect to the database.";
return ($blnSuccess, $strSimpleError, $strSystemError);
}
eval
{
#Placing require DBI here helps the Setup Script show a nice error message.
require DBI;
if (uc($ConfigHashRef->{"database_type"}) eq uc("mysql"))
{
$strConnectInfo = "dbi:" . $ConfigHashRef->{"database_type"} . ":"
. $ConfigHashRef->{"database_name"} . ":"
. $ConfigHashRef->{"database_address"};
if ($ConfigHashRef->{"database_port"})
{
$strConnectInfo .= ":" . $ConfigHashRef->{"database_port"};
}
$DB = DBI->connect($strConnectInfo, $ConfigHashRef->{"database_username"}, $ConfigHashRef->{"database_password"},{RaiseError => 1, AutoCommit => 0, PrintError => 0});
}
elsif(uc($ConfigHashRef->{"database_type"}) eq uc("SQLite"))
{
#Table name used for SQLite database file name. This is so that test mode will create a separate test_ SQLite file.
$DB = DBI->connect("dbi:" . $ConfigHashRef->{"database_type"} . ":dbname=" . $authlib::GlobalPaths{'admin_path'} . $authlib::strGlobalDBTableName . ".sqlite", undef, undef, {RaiseError => 1, PrintError => 0, AutoCommit => 0});
}
elsif(uc($ConfigHashRef->{"database_type"}) eq uc("ODBC"))
{
my $strDBAddress = $ConfigHashRef->{"database_address"};
$strConnectInfo = "DBI:" . $ConfigHashRef->{"database_type"} . ":"
. "Driver={SQL Server};Server=" . $strDBAddress . ";"
. "Database=" . $ConfigHashRef->{"database_name"} . ";"
. "uid=" . $ConfigHashRef->{"database_username"} . ";"
. "pwd=" . $ConfigHashRef->{"database_password"} . ";"
. "port=" . $ConfigHashRef->{"database_port"};
$DB = DBI->connect($strConnectInfo, undef, undef, {RaiseError => 1, AutoCommit => 0});
}
else
{
$blnError = 1;
$strSystemError = "Cannot find database for " . $ConfigHashRef->{"database_type"} . ".";
$strSimpleError = "Failed to connect to the database.";
}
};
if ($@)
{
$strSimpleError = "Failed to connect to the database.";
$strSystemError = $@;
#Cannot find database name, MySQL, MS SQL
if ($strSystemError =~ m/Unknown database/i || $strSystemError =~ m/Cannot open database/i)
{
$strSimpleError .= " Cannot find the \"" . $ConfigHashRef->{"database_name"} . "\" database. Make sure that this database has been created and that you have access to it.";
}
#Access denied for db user, MySQL, MS SQL
elsif($strSystemError =~ m/Access denied for user/i || $strSystemError =~ m/Login failed for user/i)
{
$strSimpleError .= " Access denied for database user \"" . $ConfigHashRef->{"database_username"} . "\". Check the database user name and password. Also verify that you have the database name (" . $ConfigHashRef->{"database_name"} . ") correct.";
}
#DB driver cannot be found. MySQL and MS SQL
elsif($strSystemError =~ m/install_driver(.*?)failed/i)
{
$strSimpleError .= " Cannot find database driver " . $ConfigHashRef->{"database_type"} . ".";
}
}
elsif(!$blnError)
{
($blnSuccess, $strSimpleError, $strSystemError) = CheckForDBDriver($ConfigHashRef->{"database_type"});
$authlib::GlobalDBDriverRef->{'type'} = lc($ConfigHashRef->{"database_type"});
}
else
{
$blnSuccess = 1;
}
return ($blnSuccess, $strSimpleError, $strSystemError);
}
#----------------------------------------------
#
#----------------------------------------------
sub DisconnectDatabase
{
if ($DB)
{
$DB->commit();
$DB->disconnect;
$DB = 0;
}
}
#-----------------------------------------------
#
#-----------------------------------------------
sub PrintDBDriverInfo
{
my $strCode = "";
my $strOut = "";
eval "require DBI";
$strOut .= "The required Perl DBI Module is ";
if (DBI->VERSION){
$strOut .= "installed and working. The current version is " . DBI->VERSION . ".
";
}
else
{
$strOut .= "not working. Please ensure the module is installed and available in the Perl runtime environment.";
}
$strOut .= "The script parameters show you are trying to connect to a " . $ConfigHashRef->{"database_type"} . " database.
";
if (uc($ConfigHashRef->{"database_type"}) eq uc("mysql"))
{
eval "require DBD::mysql";
$strOut .= "A MySQL database connection requires the DBD::mysql Perl Module. This module is ";
if (DBD::mysql->VERSION){
$strOut .= "installed and working. The current version is " . DBD::mysql->VERSION . ".
";
}
else
{
$strOut .= "not working
. Please ensure the module is installed and available in the Perl runtime environment.";
}
}
elsif (uc($ConfigHashRef->{"database_type"}) eq uc("ODBC"))
{
eval "require DBD::ODBC";
$strOut .= "A SQL Server database connection requires the
DBD::ODBC Perl Module. This module is ";
if (DBD::ODBC->VERSION){
$strOut .= "
installed and working. The current version is " . DBD::ODBC->VERSION . ".
";
}
else
{
$strOut .= "
not working
. Please ensure the module is installed and available in the Perl runtime environment.
A SQLite database connection requires the DBD::SQLite Perl Module. This module is ";
if (DBD::SQLite->VERSION){
$strOut .= "installed and working. The current version is " . DBD::SQLite->VERSION . ".
";
}
else
{
$strOut .= "not working. Please ensure the module is installed and available in the Perl runtime environment.";
}
}
else
{
$strOut .= "Please specify a valid database type.
";
}
return $strOut;
}
#-----------------------------------------------
#
#-----------------------------------------------
sub CheckForDBDriver
{
my ($strDriverName) = @_;
my @AvailableDrivers = DBI->available_drivers();
if(grep(/$strDriverName/i, @AvailableDrivers))
{
return (1, "", "");
}
else
{
return (0, "", "A " . $strDriverName . " driver is not installed for Perl. Please make sure that the CPAN module DBD::" . $strDriverName . " is installed and reachable from Perl.");
}
}
sub DownloadDatabase
{
binmode STDOUT;
print DownloadHeader("database.txt");
my $strSQL = "SELECT * FROM `" . $ConfigHashRef->{"studyname"} . "_history`";
my $DBInfoHash = $DB->selectall_arrayref(ProcessSQL($strSQL, 0));
use Data::Dumper;
# simple procedural interface
print Dumper($DBInfoHash);
}
#-----------------------------------------------
#
#-----------------------------------------------
sub DownloadHeader
{
my ($strFileName) = @_;
my $strOut = "";
my $blnModPerl = 0;
my $intModPerlVersion = 0;
my $strRegularHeaderTxt = "";
$strRegularHeaderTxt .= "Content-Type: application/octet-stream dat;\n";
$strRegularHeaderTxt .= "Content-Disposition: attachment; filename=\"" . $strFileName . "\"\n\n";
if (exists($ENV{'MOD_PERL'}) && defined($ENV{'MOD_PERL'}))
{
$blnModPerl = 1;
$intModPerlVersion = $ENV{'MOD_PERL'};
# Change mod_perl/1.XX to 1.X
$intModPerlVersion =~ s/mod_perl\/(\d\.\d)(.*?)$/$1/i;
}
if ($ENV{'PERL_SEND_HEADER'} || ($blnModPerl == 0))
{
$strOut .= $strRegularHeaderTxt;
}
else
{
#Only call send_http_header for mod_perl versions prior to (1.9) in the 1.26 series
#Remember to update this in authlib.pl too
if ($intModPerlVersion < 1.9)
{
my $r = Apache->request;
$r->content_type('application/octet-stream dat;');
$r->header_out("Content-Disposition" => "attachment; filename=\"" . $strFileName . "\"");
$r->send_http_header;
}
else
{
$strOut .= $strRegularHeaderTxt;
}
}
return $strOut;
}
sub ProcessSQL
{
my($strSQL, $blnCreatingTable) = @_;
if(lc($ConfigHashRef->{"database_type"}) eq "odbc")
{
$strSQL =~ s/`/\"/g;
if ($blnCreatingTable)
{
#If change here also change below
$strSQL =~ s/\s+TINYINT\(\d+\)([,\s\)])/ TINYINT$1/ig;
$strSQL =~ s/\s+INTEGER([,\s\)])/ INT$1/ig;
$strSQL =~ s/\s+LONGTEXT([,\s\)])/ nvarchar\(max\)$1/ig;
$strSQL =~ s/\s+TEXT([,\s\)])/ nvarchar\(max\)$1/ig;
$strSQL =~ s/\s+VARCHAR\s*\((\d+)\)([,\s\)])/ nvarchar\($1\)$2/ig;
$strSQL =~ s/\s+DOUBLE([,\s\)])/ decimal\(38, 16\)$1/ig;
}
}
elsif (lc($ConfigHashRef->{"database_type"}) eq "sqlite")
{
if ($blnCreatingTable)
{
$strSQL =~ s/\s+INT([,\s\)])/ INTEGER$1/ig; #SQLite needs INTEGER to do INTEGER PRIMARY KEY
$strSQL =~ s/\s+TEXT/ TEXT COLLATE NOCASE/ig; #Make all text searches in SQLite case insensitive
}
}
return $strSQL;
}