hi all !
I need some help please
I'm using a database tool for developing and driving dynamic content.
With the tool I use I make queries based on my tables and I set the sorting order of my mysql tables.
Unfortunately the sorting tool does not function.
Is there any way or 3th party script that will enforce my mysql tables to sort on the tablels and columns of my choice?
This is what I could find in the database tool files that seem to be connected to the sorting;
--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Query script: -
# Sort rows
-
If (scalar (@sortby) > 0 and $fileset{DBTYPE} NE 'SQL' or $randomorder) { # SQL databases use their own internal sort, but not necessarily a random one
-
If ($randomorder) { # Random selection overrides all other sorts
-
# Random order
-
Undef my @tempreturns;
-
$count = 0;
-
Until ($count > $finalrecord or scalar (@returns) == 0) {
-
$record = int (rand(scalar (@returns)));
-
Push (@tempreturns, splice (@returns, $record, 1));
-
$count ++;
-
}
-
@returns = @tempreturns;
-
}
-
Elsif ($finalrecord - $firstrecord + 1 >= 0.6 * scalar (@returns)) {
-
# Inbuilt sort function is faster if the number of rows to return is greater
-
# than about 60% of the total number of rows
-
@returns = sort { sortby ($a, $b) } @returns;
-
}
-
Else {
-
# Otherwise, the custom ChopSort is faster
-
&ChopSort (\@returns, \@sortby);
-
}
-
}
-
MYSQL Script: -
# Read in query header
-
Open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1);
-
@qh = <QUERYHEAD>;
-
Close QUERYHEAD;
-
For (0..1) { shift @qh; }
-
Chomp (@qh);
-
@sortby = split (/\Q[|]\E/, shift @qh); # Save sorting information for later
-
Undef %groupby;
-
%groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2); # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line
-
$rawcriteria = shift @qh; # Save criteria string for later
-
$statsnotneeded = shift @qh; # Save advanced options for later
-
$randomorder = 0; # True if random order required
-
-
-
-
# Add sorting information
-
My $sortcomm = '';
-
LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
-
If ($count % 2) {
-
If ($sortby[$count] eq 'random') {
-
$randomorder = 1;
-
Last LOOP; # Skip out of loop, as other ordering is pointless
-
}
-
Else {
-
$sortcomm .= ' DESC' if ($sortby[$count] =~ /DEC$/);
-
}
-
}
-
Else {
-
$sortcomm .= ', ' if ($count); # Don't add comma to start of first field (ie: $count == 0)
-
$sortcomm .= qq|"$sortby[$count]"|;
-
}
-
}
-
$sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
-
thanks already to any genius around
michael
PS this pieces of script are snippets of the full script, but as far as I could see only this was / is related to the sort function
11 2460
That's a lot of code. Can you please use code tags to make it easier to read? (The #-button in webpage-editor)
Can you please mark the important parts? (or comment-out the unimportant stuff). A small runnable example would be nice. Also a description what went wrong and what output you expected (quote error message).
Without tedious reading through your code, I can give you following answer that may help:
1.) Sort by using "order by" in your SQL. Useful for big tables. For example: "select name, age from table order by name desc". This is the way your code snippets are doing it (see last line in your listing): - $sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
2.) Use Schwartzian transformation (or sort-command) to sort the records AFTER you retrieved your answer from SQL. Useful for small tables, reduces database load. Drawback: you have to retieve the whole table even if you only want to display the top-ten.
Can you please use code tags to make it easier to read?
Done Can you please mark the important parts?
If I could understand it I would know what parts are important. A small runnable example would be nice.
Its just not sorting, for example i have a list thats set to textinc it still shows as:
Horse
Dog
Cat
instead of:
Cat
Dog
Horse Also a description what went wrong and what output you expected (quote error message).
No error message, just not sorting.
numinc - Not working
numdec - Not working
textinc - Not working
textdec - Not working
random - Working
The primary target for analyzing the error is line 33 in the seond listing which adds the "order by" clause to the SQL-command and causes sorting. There the variable $sortcomm should contain the field you want to sort by. $sortcomm is set previously by variable $sortby[$count].
I don't know what variable contains "textinc" which you have given. And also how this variable will influence the @sortby in some code that you have not listed here.
Can you please insert some code between line 18 and 19 of your second listing to print out the values of array @sortby?
I mean, insert following line, run and list the output here? -
printf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
And while you are at it, please insert also a similar line to show the value of the variable $sqlcomm after line 33
I added that line:
printf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
Between line 18 and 19 and got:
Internal Server Error
The server encountered an internal error or misconfiguration and was unable to complete your request.
Please contact the server administrator, webmaster and inform them of the time the error occurred, and anything you might have done that may have caused the error.
More information about this error may be available in the server error log.
--------------------------------------------------------------------------------
The error happens because your output is redirected to the browser. And the browser expects a proper header.
You can do one of the following: - Look up the message inside the Apache error log.
- Provide a header: Insert following line between line 16 and 17:
- print "Content-type: text/html\n\n";
Then you can see the debug message on the webpage. ("view source" may be needed) - Print the debug messages to a file instead:
- open LOGFILE, ">> myLog.txt" or die "Error: cannot open log file!";
-
my $message = sprintf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
-
print LOGFILE "$message";
-
close LOGFILE;
-
Hi Chaarmann,
I have added that and got the following: - count=7, sortby[count]=random
-
Content-type: text/html
-
-
count=7, sortby[count]=random
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
count=0, sortby[count]=
-
Content-type: text/html
-
-
the list is much longer but all the same with :
count=0, sortby[count]=
Content-type: text/html
The query I tested this with hast the following soring set:
Clients.ContentRanking[|]numdec[|]
Listing.Client[|]numinc[|]
Listing.Name[|]textinc[|]
Listing.MainCat[|]random[|]
Only 'random' seems to work.
Regards
Strange ... Why does your listing start with count=7? (Maybe you have not listed the beginning here) And why do you have so many count=0 (Maybe you have more than four lines in your scoring set?)
For debugging purposes, can you please do following and run it again:
1.) Your "scoring set" seems to be the content of file "files/$file/queries/$query.qh". So please only put there the single line "Clients.ContentRanking[|]numDEC[|]
". Please note that "DEC" must be written in capital letters, as what code line 25 parses for.
2.) If the output is too big, list the beginning lines and skip the end.
3.) Insert after line 33: - print "sqlcomm =$sqlcomm";
Hi chaarmann,
Im going to install a copy of the program for testing, it is to hard to test on a life site.
Is there any way we can cumunicate on msn or something like that, maybe i can give you access and you can take a look instead of me trying to follow your instructions and not really knowing what I'm doing :(
Thank you in advance for all your help
The listing 2 you provided is nearly a standalone program.
It only assumes the variables $query and $file.
The author of the code isn't a good programmer, because he should have used modularization and comments. That means he should have written the whole code in a "sub" and passing "$query" and "$file" as arguments.
The variables $query and $file ONLY determines the filename, and no global variables from outside influence this piece of code.
So I thought testing it is very easy: just replacing the filename with the fixed name "testForMichael.txt". Then putting your "soring set" (whatever that is. Sore throat?) inside it and run it.
Content of file "testForMichael.txt", the "soring set": - Clients.ContentRanking[|]numdec[|]
-
Listing.Client[|]numinc[|]
-
Listing.Name[|]textinc[|]
-
Listing.MainCat[|]random[|]
It didn't execute.
2 problems: - Every line started with a capital letter, so Perl for example couldn't recognize "For" as "for". Also the indentation was screwed up. Did you copy this code inside MS-Word and had autocorrection on? You should NEVER do that. Use Notepad next time (or an appropriate editor).
- The author used global variables all over which do not NEED to be global. I inserted
- use strict;
-
use warnings;
, so I had to define them all with "my".
Here is the complete code (standalone with debugging) which you can run yourself: -
# added for debugging
-
package michael;
-
use strict;
-
use warnings;
-
-
# Read in query header
-
-
# replaced for debugging:
-
# Open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1);
-
open (QUERYHEAD, "testForMichael.txt") or die ("Could not open query header file [testForMichael.txt].", 1);
-
-
# added for debugging
-
my (@qh, @sortby);
-
-
@qh = <QUERYHEAD>;
-
close QUERYHEAD;
-
for (0..1) { shift @qh; }
-
chomp (@qh);
-
@sortby = split (/\Q[|]\E/, shift @qh); # Save sorting information for later
-
-
# added for debugging
-
print "hello\n";
-
print "sortby=" . join(";", @sortby) . "\n";
-
-
# replaced for debugging:
-
# Undef %groupby;
-
my %groupby;
-
-
%groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2); # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line
-
-
# added for debugging
-
my ($rawcriteria, $statsnotneeded, $randomorder);
-
-
$rawcriteria = shift @qh; # Save criteria string for later
-
$statsnotneeded = shift @qh; # Save advanced options for later
-
$randomorder = 0; # True if random order required
-
-
-
-
# Add sorting information
-
my $sortcomm = '';
-
-
# added for debugging
-
my $count;
-
-
LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
-
-
# added for debugging
-
printf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
-
-
if ($count % 2) {
-
if ($sortby[$count] eq 'random') {
-
$randomorder = 1;
-
last LOOP; # Skip out of loop, as other ordering is pointless
-
}
-
else {
-
$sortcomm .= ' DESC' if ($sortby[$count] =~ /DEC$/);
-
}
-
}
-
else {
-
$sortcomm .= ', ' if ($count); # Don't add comma to start of first field (ie: $count == 0)
-
$sortcomm .= qq|"$sortby[$count]"|;
-
}
-
}
-
-
# added for debugging
-
my $sqlcomm;
-
-
$sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
-
-
# added for debugging
-
print "sqlcomm =$sqlcomm";
-
This code produces following output: - > perl testForMichael.pl
-
hello
-
sortby=Listing.Name;textinc;
-
Odd number of elements in hash assignment at testForMichael.pl line 30.
-
count=0, sortby[count]=Listing.Name
-
count=1, sortby[count]=textinc
-
sqlcomm = ORDER BY "Listing.Name"
-
So what you can see is that it ONLY reads the third line of the file and parses it.
In this example it has done the SQL-sort-clause correctly. (No random sort).
I believe this string "$sqlcomm" would be appended to an sql-command later on in code which is not listed, forming something like "select * from Listing order by Listing.name".
What you should investigate to solve the problem is following (list corresponding code): - input: the value of the variable "$query" and "$file"
- input: the content of the file ""files/$file/queries/$query.qh"" after you made your inquiry.
- output: what's happening with "$sqlcomm" afterwards, how is it connected to the SQl-inquiry command.
Hi chaarmann,
First of all thank you for trying to help me with this issue, I really apriciate it.
You said to : input: the value of the variable "$query" and "$file"
I assume that you want me to replace $query.qh and $file with the correct name in the script you made (Here is the complete code (standalone with debugging) which you can run yourself)
But then? Im totally lost with; "input: the content of the file ""files/$file/queries/$query.qh"" after you made your inquiry."
I copied your script to a notepad replaced the $query.qh and $file with the correct name but then idk what to do with it :(
As what should i save it? were should i upload it? how should i test it?
I really dont know :(
Thank you
Wanted to add one more thing;
I tried pasting your code instead of the current one but that resulted in a Internal Server Error;
im pasting the full sqlsubs.cqi here to maybe make it more simpel: - $dbconnected = 0; # True if we're connected to an SQL database
-
$dbcommitrequired = 0; # SQL Server and Access seem to crash perl interpreter with access violation if an unnecessary commit is made, so we track the necessity
-
-
use DBI;
-
use DBI qw(:sql_types);
-
-
-
-
-
## Check access to a specified script or object
-
-
sub SQLCheckAccess {
-
-
my ($records, $values, $line, $field, $th, $ipindex, $timeindex, $userindex, $passindex, $ipfield, $timefield, $userfield, $passfield, $floodtable, @newdata);
-
my ($sth, $floodhandle); # Database statement handles
-
my $floodwrite = 0;
-
-
-
# Even the admin may accidentally flood, so we check that first
-
-
if ($access[5] eq 'on' and $access[6] =~ s/\.th$//) {
-
&DBConnect(0); # Connect to database
-
($file, $table) = split (/\./, $access[6], 2);
-
local %fileset = &ReadFileSet($file);
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open flood control table header [$file/tables/$table.th].", 1);
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift (@th); }
-
$primkey = shift @th;
-
chomp $primkey;
-
LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
if ($th[$count][0] =~ /^IP_?(?:address)?$/i) {
-
$ipindex = $count;
-
$newdata[$count] = $ENV{REMOTE_ADDR};
-
}
-
elsif ($th[$count][0] =~ /^Time$/i) {
-
$timeindex = $count;
-
$newdata[$timeindex] = time;
-
}
-
else {
-
my $newdata = ($in{$th[$count][0]} or $cookie{$th[$count][0]});
-
if ($th[$count][0] eq 'LoginUser' and $newdata eq '') { # Special handling of 'user' input, to avoid keyword clashes with SQL Server
-
$newdata = ($in{user} or $cookie{user});
-
}
-
$newdata[$count] = &DataIn ($newdata, $newdata, 0, $table, $th[$count]);
-
}
-
}
-
$newdata[$primkey] = 'undefined' if ($newdata[$primkey] eq ''); # Table datasheet may encounter problems if [perhaps phoney] primary key is left blank
-
-
if ($timeindex eq '') {
-
quitit ("Incompatible table specified for flood protection [files/$file/tables/$table.th].", 1);
-
}
-
-
-
# Delete all elapsed entries
-
-
my $timelower = time - $access[7]; # Delete all entries with records prior to this time
-
$dbh->do(qq|DELETE FROM $fileset{DBPREF}$table WHERE $th[$timeindex][0] < $timelower|) || quitit ('Could not remove obsolete flood protection records. ' . $dbh->errstr, 1);
-
$dbcommitrequired = 1;
-
-
-
# Create condition for SQL flooding check query
-
-
undef my @criteria;
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
if ($count eq $ipindex) { # Note deliberate use of eq rather than ==, as $ipindex may be blank ('')
-
push (@criteria, qq|$th[$ipindex][0] IN (| . &IPAlternates ($newdata[$ipindex]) . ')');
-
}
-
elsif ($count != $timeindex) { # Expired records already removed
-
$field = $newdata[$count];
-
$field =~ s/'/\\'/g;
-
push (@criteria, qq|$th[$count][0] = '$field'|);
-
}
-
}
-
my $criteria = join (' AND ', @criteria);
-
-
-
# Check for matching flood records
-
-
$sth = $dbh->prepare(qq|SELECT * FROM $fileset{DBPREF}$table WHERE $criteria|) || quitit ('Could not prepare SQL query for selecting flood protection records. ' . $dbh->errstr, 1);
-
if ($sth->execute != 0) {
-
-
# Flooding detected
-
-
$sth->finish;
-
quitit ('Records indicate that you have already made this request recently.', 1);
-
}
-
else {
-
$sth->finish;
-
if ($sth->err) {
-
quitit ('Could not retrieve flood protection records. ' . $sth->errstr, 1);
-
}
-
-
# Record this access for future flood checks
-
-
$values = '?';
-
for (1..$#th) {
-
$values .= ', ?';
-
}
-
$floodhandle = $dbh->prepare(qq|INSERT INTO $fileset{DBPREF}$table (| . &FieldOrder(\@th) . ") VALUES ($values)") || quitit ('Could not prepare SQL statement for recording this request. ' . $dbh->errstr, 1);
-
-
# Save actual writing for after we've checked rest of access protection
-
-
$floodwrite = 1;
-
$floodfile = $file;
-
$floodtable = $table; # In case we must drop primary key
-
}
-
}
-
undef $ipindex; # Is used again for IP restriction
-
-
-
# Check if it's the admin, if so we let them in immediately
-
-
if (exists $in{user} and exists $in{pass} or $access[1] eq 'on' and $access[2] eq 'Administrator Only' or $fileset{COOKIELOGIN} eq 'On' and $cookie{user} ne '' and $cookie{pass} ne '') {
-
my (@admins);
-
open (ADMINS, 'admin/data/admins.dat') or quitit ("Could not open administrator's file.", 1);
-
for (0..1) { push (@admins, <ADMINS>) }
-
close ADMINS;
-
chomp (@admins);
-
$admins[1] = &Decrypt ($admins[1]);
-
if ($in{user} eq $admins[0] && $in{pass} eq $admins[1] || $cookie{user} eq $admins[0] && $cookie{pass} eq $admins[1] and $in{user} ne '' && $in{pass} ne '') {
-
$cachestatus = 'no'; # Don't want to cache pages that may have admin password in them
-
return 1;
-
}
-
elsif ($access[1] eq 'on' and $access[2] eq 'Administrator Only' and !(exists $in{user} and exists $in{pass})) { # Print login if we need an admin username and password but don't have them
-
&PrintLogin ($object);
-
}
-
elsif ($access[1] eq 'on' and $access[2] eq 'Administrator Only') {
-
open (BREAKLOG, ">>admin/data/breaklog.log");
-
filelock (BREAKLOG);
-
my $logaddr = (length $ENV{REMOTE_ADDR}) ? $ENV{REMOTE_ADDR} : 'No IP';
-
my $loguser = (length $in{user}) ? $in{user} : 'No user';
-
my $logobject = (length $object) ? "$in{file}.$object" : 'No object';
-
-
print BREAKLOG &DateString(time) . ' ' . &TimeString(time) . ", $logaddr, $logobject, $loguser\n";
-
close BREAKLOG;
-
quitit ('Invalid administrator username and/or password. This infringement has been logged.', 1);
-
}
-
}
-
-
-
# Check IP restrictions
-
-
if (($access[3] eq 'include' or $access[3] eq 'exclude') and $access[4] =~ s/\.th$//) { # IP restrictions are enabled and controlled by a table
-
&DBConnect(0); # Connect to database
-
-
# Explicitly handle situation where user's IP address is unknown
-
# (Behaviour: if IP address is unknown, 'include' access is denied but 'exclude' access allowed)
-
-
if ($ENV{REMOTE_ADDR} eq '' and $access[3] eq 'include') {
-
quitit ('Access to this area is restricted and your IP address is not specified.', 1);
-
}
-
-
($file, $table) = split (/\./, $access[4], 2);
-
local %fileset = &ReadFileSet($file);
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open IP restriction table [$file/tables/$table.th].", 1);
-
for (0..2) { <TABLEHEAD>; }
-
undef $ipindex; # May have already been used by flood protection check
-
-
$count = 0;
-
LOOP: while ($th = <TABLEHEAD>) {
-
@{$th[$count]} = split (/\Q[|]/, $th);
-
if ($th[$count][0] =~ /^IP_?(?:address)?$/i) {
-
$ipindex = $count;
-
last LOOP;
-
}
-
$count ++;
-
}
-
close TABLEHEAD;
-
-
if ($ipindex eq '') {
-
quitit ("Incompatible table specified for IP restriction [files/$file/tables/$table.th].", 1);
-
}
-
undef @record;
-
-
$sth = $dbh->prepare(qq|SELECT $th[$ipindex][0] FROM $fileset{DBPREF}$table WHERE $th[$ipindex][0] IN (| . &IPAlternates ($ENV{REMOTE_ADDR}) . ')') || quitit ('Could not prepare SQL query for retrieval of IP restriction addresses. ' . $dbh->errstr, 1);
-
$sth->execute;
-
$records = ($sth->fetch) ? 1 : 0;
-
$sth->finish;
-
-
if ($sth->err) {
-
quitit ('Could not retrieve IP restriction addresses. ' . $sth->errstr, 1);
-
}
-
elsif ($records and $access[3] eq 'exclude') {
-
quitit ('You have been prohibited from accessing this area. If you believe this to be a mistake, please contact the site administrator.', 1);
-
}
-
elsif (!$records and $access[3] eq 'include') {
-
quitit ('Access to this area is restricted and your IP address is not authorised.', 1);
-
}
-
}
-
elsif (($access[3] eq 'include' or $access[3] eq 'exclude') and $access[4] =~ /\.qh$/) { # IP restrictions are enabled and controlled by a query
-
&DBConnect(0); # Connect to database
-
-
local %include = %in;
-
$access[4] =~ /^(.+?)\.(.+?)\.qh$/ or quitit ("Could not recognise IP restriction query [$access[4]].", 1);
-
($file, $query) = ($1, $2);
-
local $fileset = &ReadFileSet($file);
-
-
&RunQuery ($file, $query, 0, 0, 1);
-
-
LOOP: foreach $line (@qh) { # @qh should be around from &RunQuery
-
$line =~ /^\w+\.(\w+)$/;
-
$field = $1;
-
if ($field =~ /^IP(?:address)?$/i) {
-
$ipfield = $line;
-
last LOOP;
-
}
-
}
-
if ($ipfield eq '') {
-
quitit ("Incompatible query specified for IP restriction [$access[4]].", 1);
-
}
-
LOOP: for ($count = 0; $count < scalar (@returns); $count ++) {
-
if (&IPMatch ($ENV{'REMOTE_ADDR'}, $returns[$count]{$ipfield})) {
-
if ($access[3] eq 'exclude') {
-
quitit ('You have been prohibited from accessing this area. If you believe this to be a mistake, please contact the site administrator.', 1);
-
}
-
elsif ($access[3] eq 'include') {
-
$value = 1;
-
last LOOP;
-
}
-
}
-
}
-
if ($access[3] eq 'include' and $value == 0) {
-
quitit ('Access to this area is restricted and your IP address is not authorised.', 1);
-
}
-
}
-
-
-
# Finally we check for registered user access
-
-
if ($access[1] eq 'on' and $access[2] ne '') {
-
$cookielogin = 0; # Global, to indicate whether login details should be passed through forms/URLs, or just through cookie
-
my $nonstrictlogin = 0;
-
my ($loginuser, $loginpass) = ($in{user}, $in{pass});
-
my ($loginsession, $logintoken);
-
my ($session, $token, $sessiontime);
-
-
$fileset{SESSIONTABLE} =~ /^(\w+)\.(\w+)$/;
-
my ($sessionfile, $sessiontable) = ($1, $2);
-
my $sessioncut = time - 60 * $fileset{SESSIONLENGTH}; # oldest allowable session age
-
my $tokencut = time - 60 * $fileset{TOKENLENGTH}; # oldest allowable token age
-
-
if ($loginuser eq '' and $loginpass eq '') {
-
($loginuser, $loginpass) = ($cookie{user}, $cookie{pass});
-
$nonstrictlogin = 1;
-
}
-
if ($loginuser ne '' and $loginpass eq '' and $fileset{SESSIONS} eq 'On' and $sessiontable ne '') {
-
-
# Attempt to obtain a password from session details
-
-
($loginsession, $logintoken) = ($in{session}, $in{token});
-
if ($loginsession eq '' and $logintoken eq '') {
-
($loginsession, $logintoken) = ($cookie{session}, $cookie{token});
-
$cookielogin = 1;
-
}
-
-
if ($loginuser ne '' and ($loginsession ne '' or $logintoken ne '')) {
-
&DBConnect(0); # Connect to database
-
-
$sth = $dbh->prepare("SELECT Password, Session, Token, Time FROM $fileset{DBPREF}$sessiontable WHERE Username = ? AND ((Session = ? AND Time > ?) OR (Token = ? AND Time > ?)) ORDER BY Time DESC") || quitit ('Could not prepare statement for session check. ' . $dbh->errstr, 1);
-
$sth->execute($loginuser, $loginsession, $sessioncut, $logintoken, $tokencut) || quitit ('Could not execute statement for session check. ' . $sth->errstr, 1);
-
($loginpass, $session, $token, $sessiontime) = ($sth->fetchrow_array);
-
$loginpass = &Decrypt ($loginpass);
-
$sth->finish;
-
}
-
$nonstrictlogin = 1;
-
}
-
if ($loginuser eq '' or $loginpass eq '') {
-
($loginuser, $loginpass) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS});
-
($include{user}, $include{pass}) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS}); # ...as if the user logged in that way
-
($in{user}, $in{pass}) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS});
-
$nonstrictlogin = 1;
-
}
-
-
-
if ($loginuser eq '' or $loginpass eq '') { # Print login page if login details are still blank
-
&PrintLogin ($object);
-
}
-
if ($loginuser eq $fileset{DEFAULTUSER} and $loginpass eq $fileset{DEFAULTPASS}) { # Catch user if they have explicitly typed in default account details
-
$nonstrictlogin = 1;
-
}
-
-
if ($access[2] =~ s/\.th$//) { # If users come from a table
-
&DBConnect(0); # Connect to database
-
-
($file, $table) = split (/\./, $access[2], 2);
-
local %fileset = &ReadFileSet($file);
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open registered access table [$file/tables/$table.th].", 1);
-
for (0..2) { <TABLEHEAD>; }
-
-
$value = 0;
-
$count = 0;
-
-
while ($th = <TABLEHEAD>) {
-
@{$th[$count]} = split (/\Q[|]/, $th);
-
if ($th[$count][0] =~ /^Username$/i) {
-
$userindex = $count;
-
last if ($value);
-
$value = 1;
-
}
-
elsif ($th[$count][0] =~ /^Password$/i) {
-
$passindex = $count;
-
last if ($value);
-
$value = 1;
-
}
-
$count ++;
-
}
-
if ($userindex eq '' or $passindex eq '') {
-
quitit ("Incompatible table specified for registered access [files/$file/tables/$table.th].", 1);
-
}
-
close TABLEHEAD;
-
-
$sth = $dbh->prepare(qq|SELECT $th[$passindex][0] FROM $fileset{DBPREF}$table WHERE $th[$userindex][0] = ?|) || quitit ('Could not prepare SQL statement for retrieving user information. ' . $dbh->errstr, 1);
-
$sth->execute($loginuser) || quitit ('Could not retrieve user information. ' . $sth->errstr, 1);
-
-
$value = 0;
-
LOOP: while ($pass = $sth->fetchrow_arrayref) {
-
$pass = &DataOut ($$pass[0], $th[$passindex]);
-
if ($loginpass eq $pass) {
-
$value = 1;
-
last LOOP;
-
}
-
}
-
$sth->finish;
-
-
unless ($value) {
-
if ($nonstrictlogin) {
-
&PrintLogin ($object);
-
}
-
else {
-
quitit ('Invalid username and/or password.', 1);
-
}
-
}
-
}
-
elsif ($access[2] =~ /\.qh$/) { # If users come from a query
-
&DBConnect(0); # Connect to database
-
-
local %include = %in;
-
$access[2] =~ /^(.+?)\.(.+?)\.qh$/ or quitit ('Could not recognise registered access query.', 1);
-
($file, $query) = ($1, $2);
-
-
&RunQuery ($file, $query, 0, 0, 1);
-
-
$value = 0;
-
foreach $line (@qh) { # @qh should be around from &RunQuery
-
$line =~ /^\w+\.(\w+)$/;
-
$field = $1;
-
if ($field =~ /^Username$/i) {
-
$userfield = $line;
-
last if ($value);
-
$value = 1;
-
}
-
elsif ($field =~ /^Password$/i) {
-
$passfield = $line;
-
last if ($value);
-
$value = 1;
-
}
-
}
-
if ($userfield eq '' or $passfield eq '') {
-
quitit ('Incompatible query specified for registered access.', 1);
-
}
-
-
$value = 0; # Access defaults to denied
-
LOOP: for ($count = 0; $count < scalar (@returns); $count ++) {
-
if ($loginuser eq $returns[$count]{$userfield} and $loginpass eq $returns[$count]{$passfield}) {
-
$value = 1; # Access permitted
-
last LOOP;
-
}
-
}
-
-
unless ($value) {
-
if ($nonstrictlogin) {
-
&PrintLogin ($object);
-
}
-
else {
-
quitit ('Invalid username and/or password.', 1);
-
}
-
}
-
}
-
else {
-
quitit ('Incompatible object specified for registered access.', 1);
-
}
-
-
if ($fileset{SESSIONS} eq 'On' and $sessiontable ne '' and $loginuser ne $fileset{DEFAULTUSER}) {
-
-
# Read in table header
-
-
local %fileset = &ReadFileSet($sessionfile);
-
-
open (TABLEHEAD, "files/$sessionfile/tables/$sessiontable.th") or quitit ("Could not open session control table header [$sessionfile/tables/$sessiontable.th].", 1);
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift (@th); }
-
$primkey = shift @th;
-
chomp ($primkey);
-
my ($sessionindex, $tokenindex, $userindex, $passindex, $timeindex);
-
-
LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
if ($th[$count][0] =~ /^Session$/i) {
-
$sessionindex = $count;
-
}
-
elsif ($th[$count][0] =~ /^Token$/i) {
-
$tokenindex = $count;
-
}
-
elsif ($th[$count][0] =~ /^Username$/i) {
-
$userindex = $count;
-
}
-
elsif ($th[$count][0] =~ /^Password$/i) {
-
$passindex = $count;
-
}
-
elsif ($th[$count][0] =~ /^Time$/i) {
-
$timeindex = $count;
-
}
-
}
-
-
if ($sessionindex eq '' or $tokenindex eq '' or $userindex eq '' or $passindex eq '' or $timeindex eq '') {
-
quitit ("Incompatible table specified for session control [files/$file/tables/$sessiontable.th].", 1);
-
}
-
-
if ($loginsession eq $session and $sessiontime > $sessioncut) { # login was by session
-
# Assign new token
-
-
$token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
-
$sth = $dbh->prepare("UPDATE $fileset{DBPREF}$sessiontable SET Token = ? WHERE Session = ?") || quitit ('Could not prepare statement for token update. ' . $dbh->errstr, 1);
-
$sth->execute($token, $session) || quitit ('Could not execute statement for token update. ' . $sth->errstr, 1);
-
$sth->finish;
-
-
$dbcommitrequired = 1;
-
}
-
elsif ($logintoken eq $token and $sessiontime > $tokencut) { # login was by token
-
# Assign new token, session and time
-
-
$token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
-
my $oldsession = $session;
-
$session = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$sessionindex]});
-
-
$sth = $dbh->prepare("UPDATE $fileset{DBPREF}$sessiontable SET Session = ?, Token = ?, Time = ? WHERE Session = ?") || quitit ('Could not prepare statement for token update. ' . $dbh->errstr, 1);
-
$sth->execute($session, $token, time, $oldsession) || quitit ('Could not execute statement for token update. ' . $sth->errstr, 1);
-
$sth->finish;
-
-
$dbcommitrequired = 1;
-
}
-
else { # login was by username and password
-
-
# Delete expired session records
-
-
$dbh->do("DELETE FROM $fileset{DBPREF}$sessiontable WHERE Time <= $tokencut AND Time <= $sessioncut") || quitit ('Could not remove expired sessions. ' . $dbh->errstr, 1);
-
-
-
# Add new session record
-
-
$token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
-
$session = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$sessionindex]});
-
-
my $addplaceholders = '?';
-
for (1..$#th) {
-
$addplaceholders .= ', ?';
-
}
-
-
undef my @newdata;
-
$newdata[$sessionindex] = $session;
-
$newdata[$tokenindex] = $token;
-
$newdata[$userindex] = $loginuser;
-
$newdata[$passindex] = &Encrypt($loginpass);
-
$newdata[$timeindex] = time;
-
$#newdata = $#th;
-
-
$sth = $dbh->prepare("INSERT INTO $fileset{DBPREF}$sessiontable VALUES ($addplaceholders)") || quitit ('Could not prepare statement for new session creation. ' . $dbh->errstr, 1);
-
$sth->execute(@newdata) || quitit ('Could not execute statement for new session creation. ' . $sth->errstr, 1);
-
$sth->finish;
-
-
$dbcommitrequired = 1;
-
}
-
-
# Make session info available elsewhere
-
-
$session{user} = $loginuser;
-
$session{session} = $session;
-
$session{token} = $token;
-
-
# Write session cookie if cookies enabled
-
-
if ($fileset{COOKIELOGIN} eq 'On') {
-
my $expire = ($fileset{SESSIONLENGTH} > $fileset{TOKENLENGTH}) ? $fileset{SESSIONLENGTH} : $fileset{TOKENLENGTH}; # Suitable expiration time for cookie in minutes
-
my $path = "$cgiurl/datacgi";
-
$path =~ s/^https?:\/\/.*?\..*?\///i;
-
$path = "/$path";
-
my $setcookie = new CGI::Cookie (
-
-name => "$in{file}\_session",
-
-value => \%session,
-
-expires => "+${expire}m",
-
-path => $path
-
);
-
print "Set-Cookie: $setcookie\n";
-
}
-
}
-
}
-
-
-
# Write flood protection record if necessary
-
-
if ($floodwrite) {
-
for ($count = 0; $count < scalar (@newdata); $count ++) {
-
if ($fileset{DBSOFT} =~ /^ODBC/ and length($newdata[$count]) > 255) {
-
$floodhandle->bind_param($count + 1, $newdata[$count], DBI::SQL_LONGVARCHAR) or quitit ("Could not bind_param for record insertion." . $floodhandle->errstr, 1);
-
}
-
else {
-
$floodhandle->bind_param($count + 1, $newdata[$count]) or quitit ("Could not bind_param for record insertion." . $floodhandle->errstr, 1);
-
}
-
}
-
$floodhandle->execute;
-
$dbcommitrequired = 1;
-
-
# If we couldn't add the record, it's probably because of a violation of the primary key uniqueness. As
-
# such, we use a brute force tactic and remove the primary key to try again - flood protection tables
-
# have a licence to cheat after all...
-
-
local %fileset = &ReadFileSet($floodfile);
-
-
if ($floodhandle->err) {
-
if ($fileset{DBSOFT} =~ /^ODBC/) {
-
$dbh->do(qq|ALTER TABLE $fileset{DBPREF}$floodtable DROP CONSTRAINT $fileset{DBPREF}${floodtable}_PK|);
-
}
-
else {
-
$dbh->do(qq|ALTER TABLE $fileset{DBPREF}$floodtable DROP PRIMARY KEY|);
-
}
-
if ($dbh->err) { # Something else must be wrong
-
quitit ('Could not record request for flood protection. ' . $dbh->errstr, 1);
-
}
-
else {
-
$floodhandle->execute || quitit ('Could not record request in flood protection table. ' . $floodhandle->errstr, 1);
-
}
-
}
-
$floodhandle->finish;
-
}
-
-
return 1;
-
-
-
# Finds pattern match alternatives for a given IP address
-
-
sub IPAlternates {
-
-
my $ipaddress = shift @_;
-
my @components = split (/\./, $ipaddress);
-
-
# Each component in the address can be replaced with an asterisk (*) when specifying an IP pattern. As such, there are
-
# 2**4 = 16 different patterns that the given IP address could match. We use strings of 4 bits to represent each of the
-
# numbers from 0 to 15. Each string then represents a pattern - 0s indicating asterisks and 1s the actual number usually
-
# in that position.
-
-
undef my @ipalts;
-
undef my @compalts;
-
my $bitfield = '';
-
-
for (my $count = 0; $count < 16; $count ++) {
-
vec ($bitfield, 0, 4) = $count;
-
for (0..3) {
-
push (@compalts, (vec ($bitfield, $_, 1)) ? $components[$_] : '*');
-
}
-
push (@ipalts, "'" . join ('.', @compalts) . "'");
-
undef @compalts;
-
}
-
-
return join (', ', @ipalts);
-
-
}
-
-
}
-
-
-
-
-
## Read table data
-
-
sub SQLReadTable {
-
-
&DBConnect(0); # Connect to database
-
-
my $file = shift @_;
-
my $table = shift @_;
-
$firstrecord = shift @_;
-
$firstrecord = -1 if ($firstrecord eq '');
-
$finalrecord = shift @_;
-
$finalrecord = -1 if ($finalrecord eq '');
-
my $all = shift @_; # 1 if all records should be returned
-
my $strictrange = shift @_; # 1 if record range should not be overridden
-
my ($seqfield, $count);
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift @th; }
-
-
$primkey = shift @th;
-
chomp ($primkey);
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
}
-
-
-
# Validate range of records to return variables (passed in URL)
-
-
my $sth = $dbh->prepare(qq|SELECT COUNT(*) FROM $fileset{DBPREF}$table|) || quitit ("Could not prepare calculation of number of records in <i>$table</i> table. " . $dbh->errstr, 1);
-
$sth->execute || quitit ("Could not execute calculation of number of records in <i>$table</i> table. " . $sth->errstr, 1);
-
$totalrecords = $sth->fetchrow_array;
-
$sth->finish;
-
-
if ($all) {
-
$firstrecord = 0;
-
$finalrecord = $totalrecords - 1;
-
$navfirstrecord = $firstrecord;
-
$navfinalrecord = $finalrecord;
-
}
-
else {
-
$firstrecord = 0 if ($firstrecord < 0 or $firstrecord > $totalrecords or $firstrecord > $finalrecord);
-
$navfirstrecord = $firstrecord;
-
$finalrecord = $totalrecords - 1 if ($finalrecord < 0 or $finalrecord < $firstrecord);
-
-
if ($finalrecord - $firstrecord > 99) {
-
$finalrecord = $firstrecord + 99;
-
}
-
$navfinalrecord = $finalrecord;
-
$finalrecord = $totalrecords - 1 if ($finalrecord >= $totalrecords and !$strictrange);
-
}
-
-
-
# Read in datasheet
-
-
if ($firstrecord == 0) { # Read in the number of records we need straight off
-
$sth = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table ORDER BY $th[$primkey][0] ASC|) || quitit ('Could not prepare SQL statement for reading in table record. ' . $dbh->errstr, 1);
-
$sth->execute || quitit ("Could not read in particular table record from <i>$table</i> table. " . $sth->errstr, 1);
-
}
-
else {
-
my $direction = '';
-
if ($firstrecord > ($totalrecords - $finalrecord + $firstrecord) / 2) { # Work backwards to minimise number of wasted records
-
$direction = 'DESC';
-
}
-
else {
-
$direction = 'ASC';
-
}
-
-
$sth = $dbh->prepare(qq|SELECT $th[$primkey][0] FROM $fileset{DBPREF}$table ORDER BY $th[$primkey][0] $direction|) || quitit ('Could not prepare SQL statement for table reading. ' . $dbh->errstr, 1);
-
$sth->execute || quitit ('Could not read in records from <i>$table</i> table. ' . $sth->errstr, 1);
-
-
my (@keys, $key);
-
if ($direction eq 'ASC') {
-
-
# Strip away unwanted records
-
-
$count = 0;
-
while ($count < $firstrecord and $sth->fetchrow_arrayref) {
-
$count ++;
-
}
-
-
-
# Determine primary keys of desired records
-
-
$key = $sth->fetchrow_array;
-
until ($count > $finalrecord or $sth->err) {
-
push (@keys, $key);
-
$count ++;
-
$key = $sth->fetchrow_array;
-
}
-
}
-
else {
-
# Strip away unwanted records
-
-
$count = $totalrecords - 1;
-
while ($count - 1 > $finalrecord and $sth->fetchrow_arrayref) {
-
$count --;
-
}
-
-
-
# Determine primary keys of desired records
-
-
$key = $sth->fetchrow_array;
-
until ($count < $firstrecord or $sth->err) {
-
push (@keys, $key);
-
$count --;
-
$key = $sth->fetchrow_array;
-
}
-
}
-
$sth->finish;
-
-
-
# Read in full records
-
-
if (scalar (@keys) > 0) {
-
my $keys = '?';
-
for (1..$#keys) {
-
$keys .= ', ?';
-
}
-
$sth = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table WHERE $th[$primkey][0] IN ($keys) ORDER BY $th[$primkey][0] ASC|) || quitit ('Could not prepare SQL statement for reading in table record. ' . $dbh->errstr, 1);
-
$sth->execute(@keys) || quitit ('Could not read in records from <i>$table</i> table. ' . $sth->errstr, 1);
-
}
-
}
-
-
LOOP: for ($count = 0; $count <= $finalrecord - $firstrecord; $count ++) {
-
(@{$td[$count]} = $sth->fetchrow_array) || last LOOP;
-
-
for ($subcount = 0; $subcount < scalar (@th); $subcount ++) {
-
$td[$count][$subcount] = &DataOut ($td[$count][$subcount], $th[$subcount]);
-
}
-
}
-
$sth->finish;
-
$#td = $finalrecord - $firstrecord; # Ensure that correct range is returned
-
-
}
-
-
-
-
-
## Query routine
-
-
sub SQLRunQuery {
-
-
local $file = shift @_;
-
local $query = shift @_;
-
$firstrecord = shift @_;
-
$firstrecord = -1 if ($firstrecord eq '');
-
$finalrecord = shift @_;
-
$finalrecord = -1 if ($finalrecord eq '');
-
local $all = shift @_;
-
local $qh; # Query database handle
-
-
&DBConnect(0); # Connect to database
-
require 'libs/querysubs.cgi';
-
-
undef %return;
-
-
-
# Read in query header
-
-
open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1);
-
@qh = <QUERYHEAD>;
-
close QUERYHEAD;
-
-
for (0..1) { shift @qh; }
-
chomp (@qh);
-
-
@sortby = split (/\Q[|]\E/, shift @qh); # Save sorting information for later
-
undef %groupby;
-
%groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2); # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line
-
-
$rawcriteria = shift @qh; # Save criteria string for later
-
$statsnotneeded = shift @qh; # Save advanced options for later
-
$randomorder = 0; # True if random order required
-
-
-
# Construct return structure skeleton
-
-
LOOP: foreach $key (@qh) {
-
if ($key =~ /^(\w+)\.(\w+)$/) {
-
if ($1 ne '' and $2 ne '' and $key !~ /^\d+\.\d+$/) {
-
$return{$1}{$2} = ''; # The %return hash indicates the fields we must return
-
}
-
}
-
}
-
foreach $table (keys %return) {
-
open (TABLEHEAD, "files/$file/tables/$table.th"); # Don't quit if a failed open, just carry on
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
for (0..2) { shift @th; }
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
if (exists $return{$table}{$th[$count][0]}) {
-
$return{$table}{$th[$count][0]} = \@{$th[$count]}; # Save the information from each field for data processing
-
}
-
}
-
}
-
-
-
# Prepare criteria
-
#
-
# Simplex passes times to SQL databases as integers so as to force its own formatting. The Perl 'time' function is
-
# treated in SQL WHERE clauses as a useful means to obtain the integer representation of the current time.
-
-
my $criteria = $rawcriteria;
-
$criteria =~ s/\btime\b/time/ge;
-
$criteria = &CriteriaProcess ($criteria, 1);
-
-
-
# Generate SQL command
-
-
undef my %tables;
-
undef my @fields; # Fields for SQL query
-
-
foreach $table (keys %return) { # Get participating tables
-
foreach $field (keys %{$return{$table}}) {
-
if (scalar (keys %groupby) and !exists $groupby{"$table.$field"}) {
-
push (@fields, qq|COUNT($fileset{DBPREF}$table.$field) AS "$table.$field"|); # 'AS' required or hash may have incorrect field names
-
}
-
else {
-
push (@fields, qq|$fileset{DBPREF}$table.$field AS "$table.$field"|); # 'AS' required or hash will have 'Field' keys rather than 'Table.Field'
-
}
-
}
-
}
-
-
my $sqlcomm = 'SELECT ' . join (', ', @fields) . ' FROM ';
-
foreach $key (keys %return) {
-
$sqlcomm .= "$fileset{DBPREF}$key, ";
-
}
-
$sqlcomm =~ s/, $//;
-
$sqlcomm .= " WHERE ($criteria)" unless ($criteria eq ''); # We put parentheses around criteria so we can tack on join conditions without disturbing it
-
-
-
# Read in foreign keys and prepare join conditions
-
-
my $keep = -1;
-
undef my @joincomm;
-
undef my %keys;
-
-
open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [files/$file/other/keys.dat].", 1);
-
while ($key = <KEYS>) {
-
chomp $key;
-
$keep = -1; # By default, don't include this relationship in the query
-
-
($keys{many}, $keys{one}) = split (/\Q[|]\E/, $key);
-
-
($table, $field) = split (/\./, $keys{many}, 2);
-
$keep ++ if (exists $return{$table}); # Key applies to at least one table in the query, so we record this (must apply to two to be included)
-
-
($table, $field) = split (/\./, $keys{one}, 2);
-
$keep ++ if (exists $return{$table}); # Key applies to at least one table in the query
-
-
if ($keep == 1) {
-
push (@joincomm, qq|$fileset{DBPREF}$keys{many} = $fileset{DBPREF}$keys{one}|);
-
}
-
}
-
close KEYS;
-
-
if (scalar (@joincomm) > 0) {
-
if ($criteria eq '') {
-
$sqlcomm .= ' WHERE ';
-
}
-
else {
-
$sqlcomm .= ' AND ';
-
}
-
$sqlcomm .= join (' AND ', @joincomm);
-
}
-
-
-
# Add grouping information
-
-
if (scalar (keys %groupby)) {
-
$sqlcomm .= ' GROUP BY ';
-
foreach $field (keys %groupby) {
-
$sqlcomm .= qq|$fileset{DBPREF}$field, |;
-
}
-
$sqlcomm =~ s/, $//;
-
}
-
-
-
# Add sorting information
-
-
my $sortcomm = '';
-
LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
-
if ($count % 2) {
-
if ($sortby[$count] eq 'random') {
-
$randomorder = 1;
-
last LOOP; # Skip out of loop, as other ordering is pointless
-
}
-
else {
-
$sortcomm .= ' DESC' if ($sortby[$count] =~ /dec$/);
-
}
-
}
-
else {
-
$sortcomm .= ', ' if ($count); # Don't add comma to start of first field (ie: $count == 0)
-
$sortcomm .= qq|"$sortby[$count]"|;
-
}
-
}
-
$sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
-
-
-
# Run query (note caching, as some advanced apps tend to repeat queries, and we don't want to prepare them again each the time)
-
-
if ($fileset{DBSOFT} =~ /^ODBC/) { # ODBC may not return no. records on execute, -1 instead, requiring a different process here
-
my $recquery = $sqlcomm;
-
$recquery =~ s/SELECT .+? FROM/SELECT COUNT(*) FROM/;
-
$recquery =~ s/ ORDER BY.+$//;
-
-
my $reccheck = $dbh->prepare($recquery) || quitit ('Could not prepare calculatation of expected number of return records. ' . $dbh->errstr, 1);
-
$reccheck->execute || quitit ('Could not calculate expected number of return records. ' . $reccheck->errstr, 1);
-
if ($reccheck->err) {
-
quitit ('Could not fetch expected number of return records. ' . $reccheck->errstr, 1)
-
}
-
-
if (scalar (keys %groupby)) {
-
-
# COUNT(*) gives aggregate for each group in this case, not total number of
-
# results. So we use brute force to count return records, with the lack of
-
# any more elegant method.
-
-
$totalrecords = 0;
-
while ($reccheck->fetch) {
-
$totalrecords ++;
-
}
-
}
-
else {
-
# COUNT(*) gives total number of results in this case, so we can use
-
# something slightly less brute force, but still not ideal.
-
-
($totalrecords) = $reccheck->fetchrow_array;
-
$totalrecords = int ($totalrecords);
-
}
-
-
$reccheck->finish;
-
-
$qh = $dbh->prepare($sqlcomm) || quitit ('Could not prepare SQL statement for query. ' . $dbh->errstr, 1);
-
$qh->execute || quitit ("Could not execute <i>$query</i> query. <br><br>$sqlcomm" . $qh->errstr, 1);
-
}
-
else {
-
$qh = $dbh->prepare($sqlcomm) || quitit ('Could not prepare SQL statement for query. ' . $dbh->errstr, 1);
-
$totalrecords = $qh->execute || quitit ("Could not execute <i>$query</i> query. " . $qh->errstr, 1);
-
$totalrecords = int ($totalrecords); # Get rid of 0E0 if no records returned
-
}
-
-
if ($randomorder or $statsnotneeded ne 'on') {
-
@returns = @{$qh->fetchall_arrayref({})};
-
}
-
-
-
# Wrap up query, determine statistics etc
-
-
&QueryEnd;
-
-
$qh->finish;
-
-
}
-
-
-
-
-
## Add a record
-
-
sub SQLAddRecord {
-
-
my $file = shift @_;
-
my $table = shift @_;
-
my ($count, @in);
-
-
&DBConnect(0); # Connect to database
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
-
my @th = <TABLEHEAD>;
-
close TABLEHEAD;
-
for (0..1) { shift @th; }
-
chomp (@th);
-
my $primkey = shift @th;
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]\E/, $th[$count]);
-
}
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
$in[$count] = &DataIn ('', $include{$th[$count][0]}, 0, $table, $th[$count]);
-
$include{$th[$count][0]} = &DataOut ($in[$count], $th[$count]); # Saving to pass back to return page
-
}
-
-
-
# Check foreign key integrity
-
-
&CheckForeignKeys ($file, $table);
-
-
-
# Add record
-
-
my $checkrecord = $dbh->prepare(qq|SELECT $th[$primkey][0] FROM $fileset{DBPREF}$table WHERE $th[$primkey][0] = ?|) || quitit ('Could not prepare SQL statement for record existence check. ' . $dbh->errstr, 1);
-
$checkrecord->execute($in[$primkey]) || quitit ('Could not verify non-existence of record. ' . $checkrecord->errstr, 1);
-
if ($checkrecord->fetch) {
-
quitit ("The $th[$primkey][0] $in[$primkey] already exists. Please enter another value.", 1);
-
}
-
-
-
my $addplaceholders = '?';
-
for (1..$#th) {
-
$addplaceholders .= ', ?';
-
}
-
-
$sth = $dbh->prepare(qq|INSERT INTO $fileset{DBPREF}$table (| . &FieldOrder(\@th) . ") VALUES ($addplaceholders)") || quitit ('Could not prepare SQL statement for adding record. ' . $dbh->errstr, 1);
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
if ($fileset{DBSOFT} =~ /^ODBC/ and $th[$count][1] eq 'Memo' || $th[$count][2] > 255) {
-
$sth->bind_param($count + 1, $in[$count], DBI::SQL_LONGVARCHAR) or quitit ('Could not bind_param for record insertion. ' . $sth->errstr, 1);
-
}
-
else {
-
$sth->bind_param($count + 1, $in[$count]) or quitit ('Could not bind_param for record insertion. ' . $sth->errstr, 1);
-
}
-
}
-
$sth->execute || quitit ('Could not add record. ' . $sth->errstr, 1);
-
$sth->finish;
-
$dbcommitrequired = 1;
-
-
}
-
-
-
-
-
## Edit a record
-
-
sub SQLEditRecord {
-
-
my $file = shift @_;
-
my $table = shift @_;
-
my $cascade = shift @_;
-
my ($count, @in);
-
-
&DBConnect(0); # Connect to database
-
-
if ($include{record} eq '') {
-
quitit ('No record specified for editing.', 1);
-
}
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
-
my @th = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift @th; }
-
chomp (@th);
-
my $primkey = shift @th;
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
}
-
-
my $getrecord;
-
if ($fileset{DBSOFT} =~ /^ODBC/) {
-
$getrecord = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table WHERE $th[$primkey][0] = ?|) || quitit ('Could not prepare SQL statement for record selection. ' . $dbh->errstr, 1);
-
}
-
else {
-
$getrecord = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table WHERE $th[$primkey][0] = ?|) || quitit ('Could not prepare SQL statement for record selection. ' . $dbh->errstr, 1);;
-
}
-
-
my @record;
-
$getrecord->execute($include{record}) || quitit ('Could not extract record to edit. ' . $getrecord->errstr, 1);
-
unless (@record = $getrecord->fetchrow_array) {
-
quitit ("Could not find record to edit [$include{record}].", 1);
-
}
-
-
$getrecord->finish;
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
$in[$count] = &DataIn ($record[$count], $include{$th[$count][0]}, 0, $table, $th[$count]);
-
$include{$th[$count][0]} = &DataOut ($in[$count], $th[$count]); # Saving to pass back to return page
-
}
-
-
-
# Check foreign key integrity
-
-
&CheckForeignKeys ($file, $table);
-
-
-
my $editplaceholders = qq|$th[0][0] = ?|;
-
for (1..$#th) {
-
$editplaceholders .= qq|, $th[$_][0] = ?|;
-
}
-
-
my $editrecord = $dbh->prepare(qq|UPDATE $fileset{DBPREF}$table SET $editplaceholders WHERE $th[$primkey][0] = ?|) || quitit ('Could not prepare SQL statement for record edit. ' . $dbh->errstr, 1);
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
if ($fileset{DBSOFT} =~ /^ODBC/ and $th[$count][1] eq 'Memo' || $th[$count][2] > 255) {
-
$editrecord->bind_param($count + 1, $in[$count], DBI::SQL_LONGVARCHAR) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
-
}
-
else {
-
$editrecord->bind_param($count + 1, $in[$count]) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
-
}
-
}
-
-
$editrecord->bind_param($count + 1, $include{record}) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
-
$editrecord->execute || quitit ('Could not edit record. ' . $editrecord->errstr, 1);
-
$editrecord->finish;
-
$dbcommitrequired = 1;
-
-
-
# Cascade edit extensions
-
#
-
# A cascade edit will update all foreign keys referencing this record so that their relationships aren't broken, and
-
# recursively update foreign keys in records referencing them.
-
#
-
-
if ($cascade and $in[$primkey] ne $record[$primkey]) { # Only have to update the keys, so ensure that the primary key has actually changed before we bother
-
-
# Read in foreign keys
-
-
open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [datacgifiles/$file/other/keys.dat].", 1);
-
my @keys = <KEYS>;
-
close KEYS;
-
chomp @keys;
-
-
my @cascadefields;
-
for ($count = 0; $count < scalar (@keys); $count ++) {
-
($keys[$count]{many}, $keys[$count]{one}) = split (/\Q[|]\E/, $keys[$count]);
-
if ($keys[$count]{one} eq "$table.$th[$primkey][0]") {
-
push (@cascadefields, $keys[$count]{many}); # Our starting field(s) for cascading
-
}
-
}
-
-
for ($count = 0; $count < scalar (@cascadefields); $count ++) { # Cascade should only go one level deep unless primary keys are acting as foreign keys also
-
for ($subcount = 0; $subcount < scalar (@keys); $subcount ++) {
-
if ($keys[$subcount]{one} eq $cascadefields[$count]) {
-
push (@cascadefields, $keys[$subcount]{many}); # Add to end of cascade queue
-
splice (@keys, $subcount, 1);
-
$subcount --;
-
}
-
}
-
}
-
-
my $editrecord;
-
for ($count = 0; $count < scalar (@cascadefields); $count ++) {
-
($table, $field) = split (/\./, $cascadefields[$count]);
-
$editrecord = $dbh->prepare(qq|UPDATE $fileset{DBPREF}$table SET $field = ? WHERE $field = ?|);
-
$editrecord->execute($in[$primkey], $include{record});
-
if ($editrecord->err) {
-
$editrecord->finish;
-
quitit ('Cascade edit through tables failed. ' . $sth->errstr, 1);
-
}
-
$editrecord->finish;
-
$dbcommitrequired = 1;
-
}
-
}
-
-
}
-
-
-
-
-
## Delete a record
-
-
sub SQLDeleteRecord {
-
-
$file = shift @_;
-
$table = shift @_;
-
$cascade = shift @_;
-
my ($count, @in, @th, @primkey, @fileindexes);
-
-
&DBConnect(0); # Connect to database
-
-
if ($include{record} eq '') {
-
quitit ('No record specified for deletion.', 1);
-
}
-
-
open (TABLEHEAD, "files/$include{file}/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$include{file}/tables/$table.th].", 1);
-
@{$th{$table}} = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift @{$th{$table}}; }
-
$primkey{$table} = shift @{$th{$table}};
-
chomp $primkey{$table};
-
-
my %fileindexes;
-
for ($count = 0; $count < scalar (@{$th{$table}}); $count ++) {
-
@{$th{$table}[$count]} = split (/\Q[|]/, $th{$table}[$count]);
-
if ($th{$table}[$count][1] eq 'File') {
-
push (@{$fileindexes{$table}}, $count);
-
}
-
}
-
-
my $getrecord = $dbh->prepare('SELECT ' . &FieldOrder(\@{$th{$table}}) . qq| FROM $fileset{DBPREF}$table WHERE $th{$table}[$primkey{$table}][0] = ?|) || quitit ('Could not prepare SQL statement for record selection. ' . $dbh->errstr, 1);
-
my $numaffected = $getrecord->execute($include{record}) || quitit ('Could not extract record to delete. ' . $getrecord->errstr, 1);
-
if ($numaffected == 0) {
-
quitit ("Could not find record to delete [$include{record}].", 1);
-
}
-
-
my @record = $getrecord->fetchrow_array;
-
$getrecord->finish;
-
-
for ($count = 0; $count < scalar (@{$th{$table}}); $count ++) {
-
$include{$th{$table}[$count][0]} = &DataOut ($record[$count], $th{$table}[$count]); # Saving to pass back to return page
-
}
-
-
-
-
# The record has been blanked, so clear out its file upload directory slots...
-
-
my ($index, $datafile, @files);
-
foreach $index (@{$fileindexes{$table}}) {
-
if ($record[$index] ne '') {
-
opendir (FILEDIR, "files/$file/tables/files/$record[$index]");
-
@files = readdir (FILEDIR);
-
closedir FILEDIR;
-
for (0..1) { shift (@files); }
-
-
foreach $datafile (@files) {
-
unlink ("files/$file/tables/files/$record[$index]/$datafile"); # Remove all files in the directory slot
-
}
-
rmdir ("files/$file/tables/files/$record[$index]"); # Remove the directory slot itself
-
}
-
}
-
-
my $deleterecord = $dbh->prepare(qq|DELETE FROM $fileset{DBPREF}$table WHERE $th{$table}[$primkey{$table}][0] = ?|) || quitit ('Could not prepare SQL statement for record deletion. ' . $dbh->errstr, 1);
-
$deleterecord->execute($include{record}) || quitit ('Could not extract record to delete. ' . $deleterecord->errstr, 1);
-
$deleterecord->finish;
-
$dbcommitrequired = 1;
-
-
-
# Cascade delete extensions
-
#
-
# A cascade delete will delete all records with foreign keys referencing this record, and recursively delete those
-
# pointing to them.
-
#
-
-
if ($cascade) {
-
-
# Read in foreign keys
-
-
open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [datacgi/files/$file/other/keys.dat].", 1);
-
my @keys = <KEYS>;
-
close KEYS;
-
chomp @keys;
-
-
my (@cascadefields, %coveredkeys);
-
for ($count = 0; $count < scalar (@keys); $count ++) {
-
($keys[$count]{manyfield}, $keys[$count]{onefield}) = split (/\Q[|]\E/, $keys[$count]);
-
($keys[$count]{manytable}, $keys[$count]{manyfield}) = split (/\./, $keys[$count]{manyfield}, 2);
-
($keys[$count]{onetable}, $keys[$count]{onefield}) = split (/\./, $keys[$count]{onefield}, 2);
-
-
if ($keys[$count]{onetable} eq $table) {
-
push (@cascadefields, $count); # Our starting field(s) for cascading
-
$coveredkeys{"key$count"} = 1; # Indicates key has been followed (avoid infinite loops when two tables refer to each other)
-
}
-
}
-
-
for ($count = 0; $count < scalar (@cascadefields); $count ++) {
-
for ($subcount = 0; $subcount < scalar (@keys); $subcount ++) {
-
if (!exists $coveredkeys{"key$subcount"} and $keys[$subcount]{onetable} eq $keys[$cascadefields[$count]]{manytable}) {
-
push (@cascadefields, $subcount); # Add index of this key to cascade queue
-
$coveredkeys{"key$subcount"} = 1; # Indicates key has been followed (avoid infinite loops when two tables refer to each other)
-
}
-
}
-
}
-
-
my %delkeys;
-
push (@{$delkeys{$table}}, $include{record}); # Record primary key of main deleted record
-
-
for ($count = 0; $count < scalar (@cascadefields); $count ++) {
-
$table = \$keys[$cascadefields[$count]]{manytable}; # For clarity
-
-
# Read in table header if necessary
-
-
if (!exists $th{$$table}) {
-
open (TABLEHEAD, "files/$include{file}/tables/$$table.th") or quitit ("Could not open table header file [datacgi/files/$include{file}/tables/$$table.th].", 1);
-
@{$th{$$table}} = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift @{$th{$$table}}; }
-
$primkey{$$table} = shift @{$th{$$table}};
-
chomp $primkey{$$table};
-
-
for ($subcount = 0; $subcount < scalar (@{$th{$$table}}); $subcount ++) {
-
@{$th{$$table}[$subcount]} = split (/\Q[|]/, $th{$$table}[$subcount]);
-
if ($th{$$table}[$subcount][1] eq 'File') {
-
push (@{$fileindexes{$$table}}, $subcount);
-
}
-
}
-
}
-
-
-
# Delete files
-
-
my $inkeys = '';
-
if (scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) > 0) {
-
$inkeys = '?';
-
for (1..scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) - 1) {
-
$inkeys .= ', ?';
-
}
-
$sth = $dbh->prepare('SELECT ' . &FieldOrder(\@{$th{$$table}}) . qq| FROM $fileset{DBPREF}$$table WHERE $keys[$cascadefields[$count]]{manyfield} IN ($inkeys)|) || quitit ('Could not prepare SQL statement for file upload slot deletion. ' . $dbh->errstr, 1);
-
$sth->execute(@{$delkeys{$keys[$cascadefields[$count]]{onetable}}});
-
-
if ($sth->err) {
-
quitit ('Could not delete file upload slots. ' . $sth->errstr, 1);
-
}
-
-
while ($record = $sth->fetchrow_arrayref) {
-
if ($th{$$table}[$primkey{$$table}][1] =~ /AutoInteger/) { # Special consideration for keeping leading zeroes in AutoInteger fields
-
push (@{$delkeys{$$table}}, sprintf ("%0$th{$$table}[$primkey{$$table}][2]d", $$record[$primkey{$$table}]));
-
}
-
else {
-
push (@{$delkeys{$$table}}, $$record[$primkey{$$table}]);
-
}
-
foreach $index (@{$fileindexes{$$table}}) {
-
if ($$record[$index] ne '') {
-
opendir (FILEDIR, "files/$include{file}/tables/files/$$record[$index]");
-
@files = readdir (FILEDIR);
-
closedir FILEDIR;
-
for (0..1) { shift (@files); }
-
-
foreach $file (@files) {
-
unlink ("files/$include{file}/tables/files/$$record[$index]/$file"); # Remove all files in the directory slot
-
}
-
rmdir ("files/$include{file}/tables/files/$$record[$index]"); # Remove the directory slot itself
-
}
-
}
-
}
-
$sth->finish;
-
}
-
}
-
-
my $deletekeys = 0;
-
for ($count = 0; $count < scalar (@cascadefields); $count ++) {
-
if (scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) > 0) {
-
$deletekeys = '?';
-
for (1..scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) - 1) {
-
$deletekeys .= ', ?';
-
}
-
-
$sth = $dbh->prepare(qq|DELETE FROM $fileset{DBPREF}$keys[$cascadefields[$count]]{manytable} WHERE $keys[$cascadefields[$count]]{manyfield} IN ($deletekeys)|) || quitit ('Could not prepare SQL statement for cascading record deletion. ' . $dbh->errstr, 1);
-
$sth->execute(@{$delkeys{$keys[$cascadefields[$count]]{onetable}}});
-
if ($sth->err) {
-
$sth->finish;
-
quitit ('Cascade delete through tables failed. ' . $sth->errstr, 1);
-
}
-
$sth->finish;
-
$dbcommitrequired = 1;
-
}
-
}
-
}
-
-
}
-
-
-
-
-
## Retrieves a specified record from a specified table
-
-
# Reads a record into the %record hash
-
-
sub SQLGetRecord {
-
-
&DBConnect(0); # Connect to database
-
-
my $file = shift @_;
-
my $table = shift @_;
-
my $recordprimkey = shift @_;
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift @th; }
-
$primkey = shift @th;
-
chomp $primkey;
-
-
for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
}
-
-
undef %record;
-
my @record;
-
-
$sth = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table WHERE $th[$primkey][0] = ?|) || quitit ('Could not prepare SQL statement for record selection. ' . $dbh->errstr, 1);
-
$sth->execute($recordprimkey) || quitit ('Could not find specified record. ' . $sth->errstr, 1);
-
my $temprecord = $sth->fetchrow_arrayref;
-
unless ($temprecord) {
-
quitit ("Could not find specified record [$recordprimkey].", 1);
-
}
-
$sth->finish;
-
-
for ($count = 0; $count < scalar (@{$temprecord}); $count ++) { # Put in form $record{'Table.field'}
-
$record{"$table.$th[$count][0]"} = &DataOut ($$temprecord[$count], $th[$count]);
-
}
-
-
}
-
-
-
-
-
## Sends e-mail to recipients in a system table
-
-
sub SQLSendEmailTable {
-
-
# Read in table header
-
-
&DBConnect(0); # Connect to database
-
-
open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open IP restriction table [$file/tables/$table.th].", 1);
-
@th = <TABLEHEAD>;
-
close TABLEHEAD;
-
for (0..2) { shift @th; }
-
-
LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
-
@{$th[$count]} = split (/\Q[|]/, $th[$count]);
-
if ($th[$count][0] =~ /^Email$/i) {
-
$emailindex = $count;
-
}
-
}
-
if ($emailindex eq '') {
-
quitit ("Incompatible table specified for e-mail address list [files/$file/tables/$table.th].", 1);
-
}
-
-
undef my @emails;
-
for ($count = 0; $count < scalar (@templates); $count ++) {
-
if ($templates[$count]{BccBulk}) { # Send this message by Bcc bulk method
-
-
# Read in e-mail addresses
-
-
unless (scalar (@emails) > 0) { # E-mails may already be read in
-
@emails = @{$dbh->selectcol_arrayref(qq|SELECT $th[$emailindex][0] FROM $fileset{DBPREF}$table|)};
-
quitit ("Could not retrieve e-mail addresses from <i>$table</i> table. " . $dbh->errstr, 1) if ($dbh->err);
-
}
-
-
-
# Ensure single line ending on message
-
-
chomp $templates[$count]{$messagefield};
-
$templates[$count]{$messagefield} .= "\n";
-
-
-
# Prepare Bcc value
-
-
$templates[$count]{$bccfield} .= ', ' if ($templates[$count]{$bccfield} ne '');
-
$templates[$count]{$bccfield} .= join (', ', @emails);
-
-
-
# Construct mail and send
-
# (and now would be a good time to fork!)
-
-
# Note subtlety here:
-
# 1. If we can obtain file locks, we should be able to fork. $filelock == 1, so !$filelock gives false and the fork will pass this process to the child.
-
# 2. If we can't lock files, $filelock == 0, so !$filelock gives true, so !fork need not be evaluated and the system won't attempt to fork.
-
-
if (!$filelock or !fork) { # Fork off child process if possible, so we can zombie it and not have to sit it out
-
-
if ($filelock and $dbconnected) { # Don't want child to kill off DB handle
-
$dbh->{InactiveDestroy} = 1;
-
}
-
-
if ($sendmail) {
-
# Prepare Bcc value
-
-
my $headnum = 0; # Max of 32768 chars in e-mail header, so may need to split Bcc bulk across several e-mails
-
$templates[$count]{$bccfield}[$headnum] = $templates[$count]{$bccfield};
-
-
for ($subcount = 0; $subcount < scalar (@emails); $subcount ++) {
-
$templates[$count]{$bccfield}[$headnum] .= qq|, $emails[$subcount]|;
-
if (length ($templates[$count]{$bccfield}[$headnum]) > 28000) {
-
$templates[$count]{$bccfield}[$headnum] =~ s/^, //;
-
$headnum ++;
-
}
-
}
-
$templates[$count]{$bccfield}[$headnum] =~ s/^, //;
-
-
-
# Send
-
-
for ($subcount = 0; $subcount <= $headnum; $subcount ++) {
-
open (SENDMAIL, "| $sendmailurl -t") or quitit ('Could not pipe to sendmail program.', 1);
-
print SENDMAIL qq|Content-type: text/html\n| if ($templates[$count]{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
-
print SENDMAIL qq|From: "$templates[$count]{$fromnamefield}" <$templates[$count]{$fromfield}>\nTo: "$templates[$count]{$tonamefield}" <$templates[$count]{$tofield}>\nCc: $templates[$count]{$ccfield}\nBcc: $templates[$count]{$bccfield}[$subcount]\nSubject: $templates[$count]{$subjectfield}\n\n|;
-
print SENDMAIL wrapit ($templates[$count]{$messagefield});
-
close SENDMAIL;
-
-
&LogEmail ($templates[$count], $subcount);
-
}
-
}
-
else {
-
$templates[$count]{$bccfield} .= ', ' if ($templates[$count]{$bccfield} ne '');
-
$templates[$count]{$bccfield} .= join (', ', @emails);
-
-
$smtp->mail($templates[$count]{$fromfield}) or quitit ('SMTP sender command failure.', 1);
-
-
if ($templates[$count]{$tofield} ne '') {
-
$smtp->recipient(qq|$templates[$count]{$tofield}|) or quitit ('SMTP recipient command failure.', 1);
-
}
-
-
for ($subcount = 0; $subcount < scalar (@emails); $subcount ++) {
-
if ($emails[$subcount] ne '') {
-
$smtp->recipient($emails[$subcount]) or quitit ('SMTP recipient command failure.', 1);
-
}
-
}
-
-
$smtp->data();
-
$smtp->datasend(qq|Content-type: text/html\n|) if ($templates[$count]{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
-
$smtp->datasend(qq|From: "$templates[$count]{$fromnamefield}" <$templates[$count]{$fromfield}>\n|) or quitit ('SMTP From header failure. ' . $smtp->message, 1);
-
$smtp->datasend(qq|To: "$templates[$count]{$tonamefield}" <$templates[$count]{$tofield}>\n|) or quitit ('SMTP To header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Cc: $templates[$count]{$ccfield}\n") or quitit ('SMTP Cc header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Bcc: $templates[$count]{$bccfield}\n") or quitit ('SMTP Bcc header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Subject: $templates[$count]{$subjectfield}\n") or quitit ('SMTP Subject header failure. ' . $smtp->message, 1);
-
$smtp->datasend("\n") or quitit ('SMTP data send failure. ' . $smtp->message, 1);
-
$smtp->datasend(wrapit ($templates[$count]{$messagefield})) or quitit ('SMTP data send failure. ' . $smtp->message, 1);
-
$smtp->dataend();
-
-
&LogEmail ($templates[$count]);
-
}
-
if ($filelock) { # Terminate the child if a fork
-
exit;
-
}
-
}
-
}
-
else { # Send messages one at a time, as each has customisations
-
-
$sth = $dbh->prepare('SELECT ' . &FieldOrder(\@th) . qq| FROM $fileset{DBPREF}$table|) || quitit ('Could not prepare SQL statement for e-mail address list retrieval. ' . $dbh->errstr, 1);
-
$sth->execute || quitit ('Could not retrieve e-mail address list. ' . $sth->errstr, 1);
-
-
if (!$filelock or !fork) { # Fork off child process if possible, so we can zombie it and not have to sit it out
-
-
if ($filelock and $dbconnected) { # Don't want child to kill off DB handle
-
$dbh->{InactiveDestroy} = 1;
-
}
-
-
while (@record = $sth->fetchrow_array) {
-
%temptemplate = %{$templates[$count]};
-
for ($subcount = 0; $subcount < scalar (@th); $subcount ++) {
-
$record[$subcount] = &DataOut ($record[$subcount], $th[$subcount]);
-
foreach $key (keys %temptemplate) {
-
$temptemplate{$key} =~ s/<!--$key-->/$record[$subcount]/ig unless ($record[$subcount] eq '');
-
}
-
if ($th[$subcount][0] =~ /^Email$/i) {
-
$temptemplate{$bccfield} .= "; $record[$subcount]";
-
$temptemplate{$bccfield} =~ s/^; //;
-
}
-
}
-
-
foreach $key (keys %temptemplate) {
-
-
# Repeat general replacements to catch any nested comment tags
-
-
&ReplaceGlobal (\$temptemplate{$key});
-
&ReplaceFormInput (\$temptemplate{$key});
-
&ReplaceIncludeInput (\$temptemplate{$key});
-
&ReplaceFileSpecific (\$temptemplate{$key}, $file, '');
-
&ReplaceCode (\$temptemplate{$key}, 1);
-
&ConditionalCheck (\$temptemplate{$key});
-
-
&StripTags (\$temptemplate{$key});
-
}
-
-
-
# Construct mail and send
-
-
if ($sendmail) {
-
open (SENDMAIL, "| $sendmailurl -t") or quitit ('Could not pipe to sendmail program.', 1);
-
print SENDMAIL qq|Content-type: text/html\n| if ($temptemplate{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
-
print SENDMAIL qq|From: "$temptemplate{$fromnamefield}" <$temptemplate{$fromfield}>\nTo: "$temptemplate{$tonamefield}" <$temptemplate{$tofield}>\nCc: $temptemplate{$ccfield}\nBcc: $temptemplate{$bccfield}\nSubject: $temptemplate{$subjectfield}\n\n|;
-
print SENDMAIL wrapit ($temptemplate{$messagefield});
-
close SENDMAIL;
-
-
&LogEmail (\%temptemplate);
-
}
-
else {
-
my @recipients = (split (/(?:;|,) */, $temptemplate{$tofield}), split (/(?:;|,) */, $temptemplate{$ccfield}), split (/(?:;|,) */, $temptemplate{$bccfield}));
-
$smtp->mail($temptemplate{$fromfield}) or quitit ('SMTP sender command failure.', 1);
-
$smtp->recipient(@recipients) or quitit ('SMTP recipient command failure.', 1);
-
$smtp->data();
-
$smtp->datasend(qq|Content-type: text/html\n|) if ($temptemplate{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
-
$smtp->datasend(qq|From: "$temptemplate{$fromnamefield}" <$temptemplate{$fromfield}>\n|) or quitit ('SMTP From header failure. ' . $smtp->message, 1);
-
$smtp->datasend(qq|To: "$temptemplate{$tonamefield}" <$temptemplate{$tofield}>\n|) or quitit ('SMTP To header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Cc: $temptemplate{$ccfield}\n") or quitit ('SMTP Cc header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Bcc: $temptemplate{$bccfield}\n") or quitit ('SMTP Bcc header failure. ' . $smtp->message, 1);
-
$smtp->datasend("Subject: $temptemplate{$subjectfield}\n") or quitit ('SMTP Subject header failure. ' . $smtp->message, 1);
-
$smtp->datasend("\n") or quitit ('SMTP data send failure. ' . $smtp->message, 1);
-
$smtp->datasend(wrapit ($temptemplate{$messagefield})) or quitit ('SMTP data send failure. ' . $smtp->message, 1);
-
$smtp->dataend();
-
-
&LogEmail (\%temptemplate);
-
}
-
}
-
$sth->finish;
-
-
if ($filelock) { # Terminate the child if a fork
-
exit;
-
}
-
}
-
}
-
}
-
-
}
-
-
-
-
-
## Loads primary keys from the specified table
-
-
sub SQLPrimKeys {
-
-
my $file = shift @_;
-
my $table = shift @_;
-
my $displayfield = shift @_;
-
my $count = 0;
-
-
&DBConnect(0); # Connect to database
-
-
undef @validvalues;
-
undef @displayvalues;
-
open (TABLEHEAD, "files/$file/tables/$table.th") or return 0;
-
my (@th) = <TABLEHEAD>;
-
close TABLEHEAD;
-
-
for (0..1) { shift (@th); }
-
chomp (@th);
-
$primkey = shift (@th);
-
-
my (@primth) = split (/\Q[|]\E/, $th[$primkey]);
-
undef my @dispth;
-
-
LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
-
if ($th[$count] =~ /^$displayfield\[/i) {
-
@dispth = split (/\Q[|]\E/, $th[$count]);
-
last LOOP;
-
}
-
}
-
-
if (scalar (@dispth) == 0) {
-
@dispth = @primth;
-
}
-
-
-
# Read in primary keys
-
-
my $record = ''; # Holds a primary key value
-
-
$sth = $dbh->prepare (qq|SELECT $primth[0], $dispth[0] FROM $fileset{DBPREF}$table ORDER BY $dispth[0]|) || return 0;
-
$sth->execute || return 0;
-
-
while ($record = $sth->fetchrow_arrayref) {
-
push (@validvalues, &DataOut ($$record[0], \@primth));
-
push (@displayvalues, &DataOut ($$record[1], \@dispth));
-
}
-
$sth->finish;
-
-
}
-
-
-
-
-
## Checks to see that a specified foreign key is valid
-
-
sub SQLCheckForeignKey {
-
-
# Returns 1 if value found, 0 if not
-
-
my $file = shift @_;
-
my $table = shift @_;
-
my $checkrecord = shift @_;
-
my $valid = 0;
-
-
&DBConnect(0); # Connect to database
-
-
open (CHECKTABLEHEAD, "files/$file/tables/$table.th") or return 0;
-
my (@tempth) = <CHECKTABLEHEAD>;
-
close CHECKTABLEHEAD;
-
-
for (0..1) { shift (@tempth); }
-
$primkey = shift (@tempth);
-
chomp ($primkey);
-
-
@tempth = split (/\Q[|]\E/, $tempth[$primkey]);
-
-
-
# Check foreign key validity
-
-
my $sqlcomm = qq|SELECT $tempth[0] FROM $fileset{DBPREF}$table WHERE $tempth[0] = ?|;
-
-
$sth = $dbh->prepare ($sqlcomm) || quitit ('Could not prepare SQL statement for relationship integrity check. ' . $dbh->errstr, 1);
-
$valid = $sth->execute($checkrecord) || quitit ('Could not execute SQL statement for relationship integrity check. ' . $dbh->errstr, 1);
-
$valid = ($sth->fetch) ? 1 : 0;
-
$sth->finish;
-
-
return int ($valid); # int() required to ensure that "0E0" returned by "execute" when 0 rows affected is interpreted as false
-
-
}
-
-
-
-
-
## Returns the order of fields for an SQL SELECT statement
-
-
sub FieldOrder {
-
my $thref = shift @_;
-
my $count = 0;
-
my @fieldorder;
-
-
for ($count = 0; $count < scalar (@{$thref}); $count ++) {
-
push (@fieldorder, qq|$$thref[$count][0]|);
-
}
-
return join (', ', @fieldorder);
-
}
-
-
-
-
-
## Connect to database
-
-
sub DBConnect {
-
-
# Allows us to centralise database connection settings
-
-
unless ($dbconnected) {
-
$autocommit = (shift @_) ? 1 : 0;
-
-
if ($fileset{DBSOFT} eq 'mysql') { # Some databases don't support transactions and must autocommit
-
$autocommit = 1;
-
}
-
-
my $dbsoft = $fileset{DBSOFT};
-
$dbsoft =~ s/,.*$//g; # Removes descriptive part from driver name (eg: "ODBC, Microsoft Access" -> "ODBC")
-
-
if ($dbsoft eq 'mysql') {
-
$dbh = DBI->connect("dbi:$dbsoft:$fileset{DBNAME}:host=$fileset{DBHOST}", $fileset{DBUSER}, &Decrypt($fileset{DBPASS}), { AutoCommit => $autocommit, RaiseError => 0, LongReadLen => 10000 }) || quitit ('Could not connect to SQL database. ' . DBI->errstr, 1);
-
}
-
else {
-
$dbh = DBI->connect("dbi:$dbsoft:$fileset{DBNAME}", $fileset{DBUSER}, &Decrypt($fileset{DBPASS}), { AutoCommit => $autocommit, RaiseError => 0, LongReadLen => 10000 }) || quitit ('Could not connect to SQL database. ' . DBI->errstr, 1);
-
}
-
undef $!;
-
-
$dbconnected = 1;
-
}
-
-
}
-
-
-
-
-
## Commit changes to database
-
-
sub DBCommit {
-
$dbh->commit if ($dbconnected and !$autocommit);
-
}
-
-
-
## Roll back changes to database
-
-
sub DBRollback {
-
$dbh->rollback if ($dbconnected and !$autocommit);
-
}
-
-
-
## Disconnect from database
-
-
sub DBDisconnect {
-
-
# Allows us to centralise database disconnect process
-
-
&DBCommit;
-
$dbh->disconnect if ($dbconnected);
-
$dbconnected = 0;
-
}
-
-
-
-
-
## Layer Simplex data types to SQL types
-
-
sub CoreDataType {
-
-
my $datatype = shift @_;
-
my $size = shift @_;
-
-
if (scalar (keys %lowerlayer) < 1) {
-
-
# MySQL data types
-
-
if ($fileset{DBSOFT} eq 'mysql') {
-
%lowerlayer = (
-
'Text' => 'VARCHAR',
-
'Memo' => 'TEXT',
-
'Number' => 'REAL',
-
'Integer' => 'INTEGER',
-
'Counter' => 'INTEGER',
-
'AutoInteger (Seq)' => 'INTEGER',
-
'AutoInteger (Ran)' => 'INTEGER',
-
'Date' => 'INTEGER',
-
'Time' => 'INTEGER',
-
'True/False' => 'TINYINT',
-
'Email' => 'VARCHAR',
-
'URL', => 'VARCHAR',
-
'IP Address' => 'VARCHAR',
-
'Handle' => 'CHAR',
-
'File' => 'CHAR',
-
'Password' => 'VARCHAR'
-
);
-
}
-
-
# Microsoft Access data types
-
-
elsif ($fileset{DBSOFT} eq 'ODBC, Microsoft Access') {
-
%lowerlayer = (
-
'Text' => 'VARCHAR',
-
'Memo' => 'MEMO',
-
'Number' => 'REAL',
-
'Integer' => 'INTEGER',
-
'Counter' => 'INTEGER',
-
'AutoInteger (Seq)' => 'INTEGER',
-
'AutoInteger (Ran)' => 'INTEGER',
-
'Date' => 'INTEGER',
-
'Time' => 'INTEGER',
-
'True/False' => 'INTEGER',
-
'Email' => 'VARCHAR',
-
'URL', => 'VARCHAR',
-
'IP Address' => 'VARCHAR',
-
'Handle' => 'CHAR',
-
'File' => 'CHAR',
-
'Password' => 'VARCHAR'
-
);
-
}
-
-
-
# Microsoft SQL Server data types
-
-
elsif ($fileset{DBSOFT} eq 'ODBC, Microsoft SQL Server') {
-
%lowerlayer = (
-
'Text' => 'VARCHAR',
-
'Memo' => 'TEXT',
-
'Number' => 'REAL',
-
'Integer' => 'INTEGER',
-
'Counter' => 'INTEGER',
-
'AutoInteger (Seq)' => 'INTEGER',
-
'AutoInteger (Ran)' => 'INTEGER',
-
'Date' => 'INTEGER',
-
'Time' => 'INTEGER',
-
'True/False' => 'INTEGER',
-
'Email' => 'VARCHAR',
-
'URL', => 'VARCHAR',
-
'IP Address' => 'VARCHAR',
-
'Handle' => 'CHAR',
-
'File' => 'CHAR',
-
'Password' => 'VARCHAR'
-
);
-
}
-
}
-
-
-
# Returned data type depends on DBMS
-
-
if ($size > 255) { # MySQL and SQL Server (at least) have a limit of 255 characters on a field, besides their special text fields
-
return $lowerlayer{'Memo'};
-
}
-
-
# MySQL
-
-
if ($fileset{DBSOFT} eq 'mysql') {
-
if ($lowerlayer{$datatype} =~ /^(?:REAL|TEXT)$/) { # Size need not be specified
-
return $lowerlayer{$datatype};
-
}
-
else {
-
return "$lowerlayer{$datatype}($size)";
-
}
-
}
-
-
-
# ODBC
-
-
else {
-
if ($lowerlayer{$datatype} =~ /^(?:REAL|MEMO|TEXT|INTEGER|TINYINT)/) { # Size need not be specified
-
return "$lowerlayer{$datatype}";
-
}
-
else {
-
return "$lowerlayer{$datatype}($size)";
-
}
-
}
-
-
}
-
-
return 1;
-
Sign in to post your reply or Sign up for a free account.
Similar topics
by: Kyle |
last post by:
<?php
echo "a href=\"index.php?alp=a\">A</a> ] "
."- "
."- ";
if (isset($_GET))
{
// Now what must i make the sql statment so that it will display all
the names that starts with a $_GET...
|
by: Aristotle |
last post by:
Could you please help me out with regular expressions. I'm trying to
write a perl script that proccesses some text, and i'm stuck at the
following:
need to remove from the text below all words...
|
by: Jim Hubbard |
last post by:
I want to implement the same type of activeX restrictions in my browser
application that the new SP2 for XP places in Internet Explorer.
I have found 2 web pages dealing with this functionality...
|
by: worzel |
last post by:
Hi All,
I am looking for a reg ex that will match email addresses withing <a
href=mailto blah > links.
Actually, I already crafted my own, but with a slight problem:
<a...
|
by: StevenR via AccessMonster.com |
last post by:
I have a form where I want the user to pick the fields for a Pivot Chart from
3 Combo boxes. Each Combo box holds 50+ fields from a stored procedure. I
want the user to pick 1 or no fields for each...
|
by: tbird2340 |
last post by:
I want to write an if / then statement and have tried using this:
var MyVarMailto;
if (Request.Form("LoanRequest") == "Under $250,000") {
if (Request.Form("Organization") == "1") {
MyVarMailto...
|
by: glenn123 |
last post by:
Hi, i am just about out of time to produce a working jukebox which has to perform these functions: to play music files when a track is chosen from a list which when the user presses the change genre...
|
by: Christopher |
last post by:
Urgent Help Needed: The EPVH-1.1 Visual Hull Library.
Dear All,
I am a student doing research in computer vision. The EPVH-1.1 Visual
Hull Library will really help a lot in my research.
I...
|
by: Joel Fireman |
last post by:
Help Needed: Upgrade Fedora 4 / Apache 2 to PHP 5.2.x from 5.0.4
I've been testing Joomla as a content manager for the County offices,
and it looks pretty good. Unfortunately, I decided to...
|
by: DolphinDB |
last post by:
Tired of spending countless mintues downsampling your data? Look no further!
In this article, you’ll learn how to efficiently downsample 6.48 billion high-frequency records to 61 million...
|
by: ryjfgjl |
last post by:
ExcelToDatabase: batch import excel into database automatically...
|
by: isladogs |
last post by:
The next Access Europe meeting will be on Wednesday 6 Mar 2024 starting at 18:00 UK time (6PM UTC) and finishing at about 19:15 (7.15PM).
In this month's session, we are pleased to welcome back...
|
by: isladogs |
last post by:
The next Access Europe meeting will be on Wednesday 6 Mar 2024 starting at 18:00 UK time (6PM UTC) and finishing at about 19:15 (7.15PM).
In this month's session, we are pleased to welcome back...
|
by: ArrayDB |
last post by:
The error message I've encountered is; ERROR:root:Error generating model response: exception: access violation writing 0x0000000000005140, which seems to be indicative of an access violation...
|
by: PapaRatzi |
last post by:
Hello,
I am teaching myself MS Access forms design and Visual Basic. I've created a table to capture a list of Top 30 singles and forms to capture new entries. The final step is a form (unbound)...
|
by: CloudSolutions |
last post by:
Introduction:
For many beginners and individual users, requiring a credit card and email registration may pose a barrier when starting to use cloud servers. However, some cloud server providers now...
|
by: Shællîpôpï 09 |
last post by:
If u are using a keypad phone, how do u turn on JavaScript, to access features like WhatsApp, Facebook, Instagram....
|
by: Faith0G |
last post by:
I am starting a new it consulting business and it's been a while since I setup a new website. Is wordpress still the best web based software for hosting a 5 page website? The webpages will be...
| |