473,320 Members | 2,004 Online
Bytes | Software Development & Data Engineering Community
Post Job

Home Posts Topics Members FAQ

Join Bytes to post your question to a community of 473,320 software developers and data experts.

Mysql database sorting question

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:
Expand|Select|Wrap|Line Numbers
  1. # Sort rows
  2. If (scalar (@sortby) > 0 and $fileset{DBTYPE} NE 'SQL' or $randomorder) { # SQL databases use their own internal sort, but not necessarily a random one
  3. If ($randomorder) { # Random selection overrides all other sorts
  4. # Random order
  5. Undef my @tempreturns;
  6. $count = 0;
  7. Until ($count > $finalrecord or scalar (@returns) == 0) {
  8. $record = int (rand(scalar (@returns)));
  9. Push (@tempreturns, splice (@returns, $record, 1));
  10. $count ++;
  11. }
  12. @returns = @tempreturns;
  13. }
  14. Elsif ($finalrecord - $firstrecord + 1 >= 0.6 * scalar (@returns)) {
  15. # Inbuilt sort function is faster if the number of rows to return is greater
  16. # than about 60% of the total number of rows
  17. @returns = sort { sortby ($a, $b) } @returns;
  18. }
  19. Else {
  20. # Otherwise, the custom ChopSort is faster
  21. &ChopSort (\@returns, \@sortby);
  22. }
  23. }
  24.  
MYSQL Script:
Expand|Select|Wrap|Line Numbers
  1. # Read in query header
  2. Open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1);
  3. @qh = <QUERYHEAD>;
  4. Close QUERYHEAD;
  5. For (0..1) { shift @qh; }
  6. Chomp (@qh);
  7. @sortby = split (/\Q[|]\E/, shift @qh); # Save sorting information for later
  8. Undef %groupby;
  9. %groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2); # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line
  10. $rawcriteria = shift @qh; # Save criteria string for later
  11. $statsnotneeded = shift @qh; # Save advanced options for later
  12. $randomorder = 0; # True if random order required
  13.  
  14.  
  15.  
  16. # Add sorting information
  17. My $sortcomm = '';
  18. LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
  19. If ($count % 2) {
  20. If ($sortby[$count] eq 'random') {
  21. $randomorder = 1;
  22. Last LOOP; # Skip out of loop, as other ordering is pointless
  23. }
  24. Else {
  25. $sortcomm .= ' DESC' if ($sortby[$count] =~ /DEC$/);
  26. }
  27. }
  28. Else {
  29. $sortcomm .= ', ' if ($count); # Don't add comma to start of first field (ie: $count == 0)
  30. $sortcomm .= qq|"$sortby[$count]"|;
  31. }
  32. }
  33. $sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
  34.  
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
Sep 6 '10 #1
11 2460
chaarmann
785 Expert 512MB
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):
Expand|Select|Wrap|Line Numbers
  1. $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.
Sep 6 '10 #2
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
Sep 6 '10 #3
chaarmann
785 Expert 512MB
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?
Expand|Select|Wrap|Line Numbers
  1. 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
Sep 7 '10 #4
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.


--------------------------------------------------------------------------------
Sep 7 '10 #5
chaarmann
785 Expert 512MB
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:
  1. Look up the message inside the Apache error log.
  2. Provide a header: Insert following line between line 16 and 17:
    Expand|Select|Wrap|Line Numbers
    1. print "Content-type: text/html\n\n";
    Then you can see the debug message on the webpage. ("view source" may be needed)
  3. Print the debug messages to a file instead:
    Expand|Select|Wrap|Line Numbers
    1. open LOGFILE, ">> myLog.txt" or die "Error: cannot open log file!";
    2. my $message = sprintf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
    3. print LOGFILE "$message";
    4. close LOGFILE;
    5.  
Sep 8 '10 #6
Hi Chaarmann,

I have added that and got the following:

Expand|Select|Wrap|Line Numbers
  1. count=7, sortby[count]=random
  2. Content-type: text/html
  3.  
  4. count=7, sortby[count]=random
  5. Content-type: text/html
  6.  
  7. count=0, sortby[count]=
  8. Content-type: text/html
  9.  
  10. count=0, sortby[count]=
  11. Content-type: text/html
  12.  
  13. count=0, sortby[count]=
  14. Content-type: text/html
  15.  
  16. count=0, sortby[count]=
  17. Content-type: text/html
  18.  
  19. count=0, sortby[count]=
  20. Content-type: text/html
  21.  
  22. count=0, sortby[count]=
  23. Content-type: text/html
  24.  
  25. count=0, sortby[count]=
  26. Content-type: text/html
  27.  
  28. count=0, sortby[count]=
  29. Content-type: text/html
  30.  
  31. count=0, sortby[count]=
  32. Content-type: text/html
  33.  
  34. count=0, sortby[count]=
  35. Content-type: text/html
  36.  
  37.  
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
Sep 8 '10 #7
chaarmann
785 Expert 512MB
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:
Expand|Select|Wrap|Line Numbers
  1. print "sqlcomm =$sqlcomm"; 
Sep 8 '10 #8
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
Sep 8 '10 #9
chaarmann
785 Expert 512MB
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":
Expand|Select|Wrap|Line Numbers
  1. Clients.ContentRanking[|]numdec[|]
  2. Listing.Client[|]numinc[|]
  3. Listing.Name[|]textinc[|]
  4. Listing.MainCat[|]random[|]
It didn't execute.
2 problems:
  1. 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).
  2. The author used global variables all over which do not NEED to be global. I inserted
    Expand|Select|Wrap|Line Numbers
    1. use strict;
    2. use warnings;
    , so I had to define them all with "my".

Here is the complete code (standalone with debugging) which you can run yourself:
Expand|Select|Wrap|Line Numbers
  1. # added for debugging
  2. package michael;
  3. use strict;
  4. use warnings;
  5.  
  6. # Read in query header 
  7.  
  8. # replaced for debugging: 
  9. # Open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1); 
  10. open (QUERYHEAD, "testForMichael.txt") or die ("Could not open query header file [testForMichael.txt].", 1); 
  11.  
  12. # added for debugging
  13. my (@qh, @sortby);
  14.  
  15. @qh = <QUERYHEAD>; 
  16. close QUERYHEAD; 
  17. for (0..1) { shift @qh; } 
  18. chomp (@qh); 
  19. @sortby = split (/\Q[|]\E/, shift @qh); # Save sorting information for later 
  20.  
  21. # added for debugging
  22. print "hello\n";
  23. print "sortby=" . join(";", @sortby) . "\n";
  24.  
  25. # replaced for debugging: 
  26. # Undef %groupby; 
  27. my %groupby;
  28.  
  29. %groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2); # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line 
  30.  
  31. # added for debugging
  32. my ($rawcriteria, $statsnotneeded, $randomorder);
  33.  
  34. $rawcriteria = shift @qh; # Save criteria string for later 
  35. $statsnotneeded = shift @qh; # Save advanced options for later 
  36. $randomorder = 0; # True if random order required 
  37.  
  38.  
  39.  
  40. # Add sorting information 
  41. my $sortcomm = '';
  42.  
  43. # added for debugging
  44. my $count;
  45.  
  46. LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
  47.  
  48.     # added for debugging
  49.     printf("count=%s, sortby[count]=%s\n", $count, $sortby[$count]);
  50.  
  51.     if ($count % 2) { 
  52.         if ($sortby[$count] eq 'random') { 
  53.             $randomorder = 1; 
  54.             last LOOP; # Skip out of loop, as other ordering is pointless 
  55.         } 
  56.         else { 
  57.             $sortcomm .= ' DESC' if ($sortby[$count] =~ /DEC$/); 
  58.         } 
  59.     } 
  60.     else { 
  61.         $sortcomm .= ', ' if ($count); # Don't add comma to start of first field (ie: $count == 0) 
  62.         $sortcomm .= qq|"$sortby[$count]"|; 
  63.     } 
  64.  
  65. # added for debugging
  66. my $sqlcomm;
  67.  
  68. $sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0); 
  69.  
  70. # added for debugging
  71. print "sqlcomm =$sqlcomm";
  72.  
This code produces following output:
Expand|Select|Wrap|Line Numbers
  1. > perl testForMichael.pl
  2. hello
  3. sortby=Listing.Name;textinc;
  4. Odd number of elements in hash assignment at testForMichael.pl line 30.
  5. count=0, sortby[count]=Listing.Name
  6. count=1, sortby[count]=textinc
  7. sqlcomm = ORDER BY "Listing.Name"
  8.  
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.
Sep 9 '10 #10
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
Sep 9 '10 #11
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:

Expand|Select|Wrap|Line Numbers
  1. $dbconnected = 0;     # True if we're connected to an SQL database
  2. $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
  3.  
  4. use DBI;
  5. use DBI qw(:sql_types);
  6.  
  7.  
  8.  
  9.  
  10. ## Check access to a specified script or object
  11.  
  12. sub SQLCheckAccess {
  13.  
  14. my ($records, $values, $line, $field, $th, $ipindex, $timeindex, $userindex, $passindex, $ipfield, $timefield, $userfield, $passfield, $floodtable, @newdata);
  15. my ($sth, $floodhandle);     # Database statement handles
  16. my $floodwrite = 0;
  17.  
  18.  
  19. # Even the admin may accidentally flood, so we check that first
  20.  
  21. if ($access[5] eq 'on' and $access[6] =~ s/\.th$//) {
  22.     &DBConnect(0);    # Connect to database 
  23.     ($file, $table) = split (/\./, $access[6], 2);
  24.     local %fileset = &ReadFileSet($file);
  25.  
  26.     open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open flood control table header [$file/tables/$table.th].", 1);
  27.         @th = <TABLEHEAD>;
  28.     close TABLEHEAD;
  29.  
  30.     for (0..1) { shift (@th); }
  31.     $primkey = shift @th;
  32.     chomp $primkey;
  33.     LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
  34.         @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  35.         if ($th[$count][0] =~ /^IP_?(?:address)?$/i) {
  36.             $ipindex = $count;
  37.             $newdata[$count] = $ENV{REMOTE_ADDR};
  38.         }
  39.         elsif ($th[$count][0] =~ /^Time$/i) {
  40.             $timeindex = $count;
  41.             $newdata[$timeindex] = time;
  42.         }
  43.         else {
  44.             my $newdata = ($in{$th[$count][0]} or $cookie{$th[$count][0]});
  45.             if ($th[$count][0] eq 'LoginUser' and $newdata eq '') {     # Special handling of 'user' input, to avoid keyword clashes with SQL Server
  46.                 $newdata = ($in{user} or $cookie{user});
  47.             }
  48.             $newdata[$count] = &DataIn ($newdata, $newdata, 0, $table, $th[$count]);
  49.         }
  50.     }
  51.     $newdata[$primkey] = 'undefined' if ($newdata[$primkey] eq '');     # Table datasheet may encounter problems if [perhaps phoney] primary key is left blank
  52.  
  53.     if ($timeindex eq '') {
  54.         quitit ("Incompatible table specified for flood protection [files/$file/tables/$table.th].", 1);
  55.     }
  56.  
  57.  
  58.     # Delete all elapsed entries
  59.  
  60.     my $timelower = time - $access[7];     # Delete all entries with records prior to this time
  61.     $dbh->do(qq|DELETE FROM $fileset{DBPREF}$table WHERE $th[$timeindex][0] < $timelower|) || quitit ('Could not remove obsolete flood protection records. ' . $dbh->errstr, 1);
  62.     $dbcommitrequired = 1;
  63.  
  64.  
  65.     # Create condition for SQL flooding check query
  66.  
  67.     undef my @criteria;
  68.     for ($count = 0; $count < scalar (@th); $count ++) {
  69.         if ($count eq $ipindex) {     # Note deliberate use of eq rather than ==, as $ipindex may be blank ('')
  70.             push (@criteria, qq|$th[$ipindex][0] IN (| . &IPAlternates ($newdata[$ipindex]) . ')');
  71.         }
  72.         elsif ($count != $timeindex) {     # Expired records already removed
  73.             $field = $newdata[$count];
  74.             $field =~ s/'/\\'/g;
  75.             push (@criteria, qq|$th[$count][0] = '$field'|);
  76.         }
  77.     }
  78.     my $criteria = join (' AND ', @criteria);
  79.  
  80.  
  81.     # Check for matching flood records
  82.  
  83.     $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);
  84.     if ($sth->execute != 0) {
  85.  
  86.         # Flooding detected
  87.  
  88.         $sth->finish;
  89.         quitit ('Records indicate that you have already made this request recently.', 1);
  90.     }
  91.     else {
  92.         $sth->finish;
  93.         if ($sth->err) {
  94.             quitit ('Could not retrieve flood protection records. ' . $sth->errstr, 1);
  95.         }
  96.  
  97.         # Record this access for future flood checks
  98.  
  99.         $values = '?';
  100.         for (1..$#th) {
  101.             $values .= ', ?';
  102.         }
  103.         $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);
  104.  
  105.         # Save actual writing for after we've checked rest of access protection
  106.  
  107.         $floodwrite = 1;
  108.         $floodfile = $file;
  109.         $floodtable = $table;     # In case we must drop primary key
  110.     }
  111. }
  112. undef $ipindex;     # Is used again for IP restriction
  113.  
  114.  
  115. # Check if it's the admin, if so we let them in immediately
  116.  
  117. 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 '') {
  118.     my (@admins);
  119.     open (ADMINS, 'admin/data/admins.dat') or quitit ("Could not open administrator's file.", 1);
  120.         for (0..1) { push (@admins, <ADMINS>) }
  121.     close ADMINS;
  122.     chomp (@admins);
  123.     $admins[1] = &Decrypt ($admins[1]);
  124.     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 '') {
  125.         $cachestatus = 'no';     # Don't want to cache pages that may have admin password in them
  126.         return 1;
  127.     }
  128.     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
  129.         &PrintLogin ($object);
  130.     }
  131.     elsif ($access[1] eq 'on' and $access[2] eq 'Administrator Only') {
  132.         open (BREAKLOG, ">>admin/data/breaklog.log");
  133.             filelock (BREAKLOG);
  134.             my $logaddr = (length $ENV{REMOTE_ADDR}) ? $ENV{REMOTE_ADDR} : 'No IP';
  135.             my $loguser = (length $in{user}) ? $in{user} : 'No user';
  136.             my $logobject = (length $object) ? "$in{file}.$object" : 'No object';
  137.  
  138.             print BREAKLOG &DateString(time) . ' ' . &TimeString(time) . ", $logaddr, $logobject, $loguser\n";
  139.         close BREAKLOG;
  140.         quitit ('Invalid administrator username and/or password. This infringement has been logged.', 1);
  141.     }
  142. }
  143.  
  144.  
  145. # Check IP restrictions
  146.  
  147. if (($access[3] eq 'include' or $access[3] eq 'exclude') and $access[4] =~ s/\.th$//) {     # IP restrictions are enabled and controlled by a table
  148.     &DBConnect(0);    # Connect to database 
  149.  
  150.     # Explicitly handle situation where user's IP address is unknown
  151.     # (Behaviour: if IP address is unknown, 'include' access is denied but 'exclude' access allowed)
  152.  
  153.     if ($ENV{REMOTE_ADDR} eq '' and $access[3] eq 'include') {
  154.         quitit ('Access to this area is restricted and your IP address is not specified.', 1);
  155.     }
  156.  
  157.     ($file, $table) = split (/\./, $access[4], 2);
  158.     local %fileset = &ReadFileSet($file);
  159.  
  160.     open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open IP restriction table [$file/tables/$table.th].", 1);
  161.     for (0..2) { <TABLEHEAD>; }
  162.     undef $ipindex;     # May have already been used by flood protection check
  163.  
  164.     $count = 0;
  165.     LOOP: while ($th = <TABLEHEAD>) {
  166.         @{$th[$count]} = split (/\Q[|]/, $th);
  167.         if ($th[$count][0] =~ /^IP_?(?:address)?$/i) {
  168.             $ipindex = $count;
  169.             last LOOP;
  170.         }
  171.         $count ++;
  172.     }
  173.     close TABLEHEAD;
  174.  
  175.     if ($ipindex eq '') {
  176.         quitit ("Incompatible table specified for IP restriction [files/$file/tables/$table.th].", 1);
  177.     }
  178.     undef @record;
  179.  
  180.     $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);
  181.     $sth->execute;
  182.     $records = ($sth->fetch) ? 1 : 0;
  183.     $sth->finish;
  184.  
  185.     if ($sth->err) {
  186.         quitit ('Could not retrieve IP restriction addresses. ' . $sth->errstr, 1);
  187.     }
  188.     elsif ($records and $access[3] eq 'exclude') {
  189.         quitit ('You have been prohibited from accessing this area. If you believe this to be a mistake, please contact the site administrator.', 1);
  190.     }
  191.     elsif (!$records and $access[3] eq 'include') {
  192.         quitit ('Access to this area is restricted and your IP address is not authorised.', 1);
  193.     }
  194. }
  195. elsif (($access[3] eq 'include' or $access[3] eq 'exclude') and $access[4] =~ /\.qh$/) {     # IP restrictions are enabled and controlled by a query
  196.     &DBConnect(0);    # Connect to database 
  197.  
  198.     local %include = %in;
  199.     $access[4] =~ /^(.+?)\.(.+?)\.qh$/ or quitit ("Could not recognise IP restriction query [$access[4]].", 1);
  200.     ($file, $query) = ($1, $2);
  201.     local $fileset = &ReadFileSet($file);
  202.  
  203.     &RunQuery ($file, $query, 0, 0, 1);
  204.  
  205.     LOOP: foreach $line (@qh) {     # @qh should be around from &RunQuery
  206.         $line =~ /^\w+\.(\w+)$/;
  207.         $field = $1;
  208.         if ($field =~ /^IP(?:address)?$/i) {
  209.             $ipfield = $line;
  210.             last LOOP;
  211.         }
  212.     }
  213.     if ($ipfield eq '') {
  214.         quitit ("Incompatible query specified for IP restriction [$access[4]].", 1);
  215.     }
  216.     LOOP: for ($count = 0; $count < scalar (@returns); $count ++) {
  217.         if (&IPMatch ($ENV{'REMOTE_ADDR'}, $returns[$count]{$ipfield})) {
  218.             if ($access[3] eq 'exclude') {
  219.                 quitit ('You have been prohibited from accessing this area. If you believe this to be a mistake, please contact the site administrator.', 1);
  220.             }
  221.             elsif ($access[3] eq 'include') {
  222.                 $value = 1;
  223.                 last LOOP;
  224.             }
  225.         }
  226.     }
  227.     if ($access[3] eq 'include' and $value == 0) {
  228.         quitit ('Access to this area is restricted and your IP address is not authorised.', 1);
  229.     }
  230. }
  231.  
  232.  
  233. # Finally we check for registered user access
  234.  
  235. if ($access[1] eq 'on' and $access[2] ne '') {
  236.     $cookielogin = 0;     # Global, to indicate whether login details should be passed through forms/URLs, or just through cookie
  237.     my $nonstrictlogin = 0;
  238.     my ($loginuser, $loginpass) = ($in{user}, $in{pass});
  239.     my ($loginsession, $logintoken);
  240.     my ($session, $token, $sessiontime);
  241.  
  242.     $fileset{SESSIONTABLE} =~ /^(\w+)\.(\w+)$/;
  243.     my ($sessionfile, $sessiontable) = ($1, $2);
  244.     my $sessioncut = time - 60 * $fileset{SESSIONLENGTH};     # oldest allowable session age
  245.     my $tokencut = time - 60 * $fileset{TOKENLENGTH};     # oldest allowable token age
  246.  
  247.     if ($loginuser eq '' and $loginpass eq '') {
  248.         ($loginuser, $loginpass) = ($cookie{user}, $cookie{pass});
  249.         $nonstrictlogin = 1;
  250.     }
  251.     if ($loginuser ne '' and $loginpass eq '' and $fileset{SESSIONS} eq 'On' and $sessiontable ne '') {
  252.  
  253.         # Attempt to obtain a password from session details
  254.  
  255.         ($loginsession, $logintoken) = ($in{session}, $in{token});
  256.         if ($loginsession eq '' and $logintoken eq '') {
  257.             ($loginsession, $logintoken) = ($cookie{session}, $cookie{token});
  258.             $cookielogin = 1;
  259.         }
  260.  
  261.         if ($loginuser ne '' and ($loginsession ne '' or $logintoken ne '')) {
  262.             &DBConnect(0);    # Connect to database 
  263.  
  264.             $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);
  265.             $sth->execute($loginuser, $loginsession, $sessioncut, $logintoken, $tokencut) || quitit ('Could not execute statement for session check. ' . $sth->errstr, 1);
  266.             ($loginpass, $session, $token, $sessiontime) = ($sth->fetchrow_array);
  267.             $loginpass = &Decrypt ($loginpass);
  268.             $sth->finish;
  269.         }
  270.         $nonstrictlogin = 1;
  271.     }
  272.     if ($loginuser eq '' or $loginpass eq '') {
  273.         ($loginuser, $loginpass) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS});
  274.         ($include{user}, $include{pass}) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS});    # ...as if the user logged in that way
  275.         ($in{user}, $in{pass}) = ($fileset{DEFAULTUSER}, $fileset{DEFAULTPASS});
  276.         $nonstrictlogin = 1;
  277.     }
  278.  
  279.  
  280.     if ($loginuser eq '' or $loginpass eq '') {     # Print login page if login details are still blank
  281.         &PrintLogin ($object);
  282.     }
  283.     if ($loginuser eq $fileset{DEFAULTUSER} and $loginpass eq $fileset{DEFAULTPASS}) {     # Catch user if they have explicitly typed in default account details
  284.         $nonstrictlogin = 1;
  285.     }
  286.  
  287.     if ($access[2] =~ s/\.th$//) {     # If users come from a table
  288.         &DBConnect(0);    # Connect to database 
  289.  
  290.         ($file, $table) = split (/\./, $access[2], 2);
  291.         local %fileset = &ReadFileSet($file);
  292.  
  293.         open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open registered access table [$file/tables/$table.th].", 1);
  294.         for (0..2) { <TABLEHEAD>; }
  295.  
  296.         $value = 0;
  297.         $count = 0;
  298.  
  299.         while ($th = <TABLEHEAD>) {
  300.             @{$th[$count]} = split (/\Q[|]/, $th);
  301.             if ($th[$count][0] =~ /^Username$/i) {
  302.                 $userindex = $count;
  303.                 last if ($value);
  304.                 $value = 1;
  305.             }
  306.             elsif ($th[$count][0] =~ /^Password$/i) {
  307.                 $passindex = $count;
  308.                 last if ($value);
  309.                 $value = 1;
  310.             }
  311.             $count ++;
  312.         }
  313.         if ($userindex eq '' or $passindex eq '') {
  314.             quitit ("Incompatible table specified for registered access [files/$file/tables/$table.th].", 1);
  315.         }
  316.         close TABLEHEAD;
  317.  
  318.         $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);
  319.         $sth->execute($loginuser) || quitit ('Could not retrieve user information. ' . $sth->errstr, 1);
  320.  
  321.         $value = 0;
  322.         LOOP: while ($pass = $sth->fetchrow_arrayref) {
  323.             $pass = &DataOut ($$pass[0], $th[$passindex]);
  324.             if ($loginpass eq $pass) {
  325.                 $value = 1;
  326.                 last LOOP;
  327.             }
  328.         }
  329.         $sth->finish;
  330.  
  331.         unless ($value) {
  332.             if ($nonstrictlogin) {
  333.                 &PrintLogin ($object);
  334.             }
  335.             else {
  336.                 quitit ('Invalid username and/or password.', 1);
  337.             }
  338.         }
  339.     }
  340.     elsif ($access[2] =~ /\.qh$/) {     # If users come from a query
  341.         &DBConnect(0);    # Connect to database 
  342.  
  343.         local %include = %in;
  344.         $access[2] =~ /^(.+?)\.(.+?)\.qh$/ or quitit ('Could not recognise registered access query.', 1);
  345.         ($file, $query) = ($1, $2);
  346.  
  347.         &RunQuery ($file, $query, 0, 0, 1);
  348.  
  349.         $value = 0;
  350.         foreach $line (@qh) {     # @qh should be around from &RunQuery
  351.             $line =~ /^\w+\.(\w+)$/;
  352.             $field = $1;
  353.             if ($field =~ /^Username$/i) {
  354.                 $userfield = $line;
  355.                 last if ($value);
  356.                 $value = 1;
  357.             }
  358.             elsif ($field =~ /^Password$/i) {
  359.                 $passfield = $line;
  360.                 last if ($value);
  361.                 $value = 1;
  362.             }
  363.         }
  364.         if ($userfield eq '' or $passfield eq '') {
  365.             quitit ('Incompatible query specified for registered access.', 1);
  366.         }
  367.  
  368.         $value = 0;     # Access defaults to denied
  369.         LOOP: for ($count = 0; $count < scalar (@returns); $count ++) {
  370.             if ($loginuser eq $returns[$count]{$userfield} and $loginpass eq $returns[$count]{$passfield}) {
  371.                 $value = 1;     # Access permitted
  372.                 last LOOP;
  373.             }
  374.         }
  375.  
  376.         unless ($value) {
  377.             if ($nonstrictlogin) {
  378.                 &PrintLogin ($object);
  379.             }
  380.             else {
  381.                 quitit ('Invalid username and/or password.', 1);
  382.             }
  383.         }
  384.     }
  385.     else {
  386.         quitit ('Incompatible object specified for registered access.', 1);
  387.     }
  388.  
  389.     if ($fileset{SESSIONS} eq 'On' and $sessiontable ne '' and $loginuser ne $fileset{DEFAULTUSER}) {
  390.  
  391.         # Read in table header
  392.  
  393.         local %fileset = &ReadFileSet($sessionfile);
  394.  
  395.         open (TABLEHEAD, "files/$sessionfile/tables/$sessiontable.th") or quitit ("Could not open session control table header [$sessionfile/tables/$sessiontable.th].", 1);
  396.             @th = <TABLEHEAD>;
  397.         close TABLEHEAD;
  398.  
  399.         for (0..1) { shift (@th); }
  400.         $primkey = shift @th;
  401.         chomp ($primkey);
  402.         my ($sessionindex, $tokenindex, $userindex, $passindex, $timeindex);
  403.  
  404.         LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
  405.             @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  406.             if ($th[$count][0] =~ /^Session$/i) {
  407.                 $sessionindex = $count;
  408.             }
  409.             elsif ($th[$count][0] =~ /^Token$/i) {
  410.                 $tokenindex = $count;
  411.             }
  412.             elsif ($th[$count][0] =~ /^Username$/i) {
  413.                 $userindex = $count;
  414.             }
  415.             elsif ($th[$count][0] =~ /^Password$/i) {
  416.                 $passindex = $count;
  417.             }
  418.             elsif ($th[$count][0] =~ /^Time$/i) {
  419.                 $timeindex = $count;
  420.             }
  421.         }
  422.  
  423.         if ($sessionindex eq '' or $tokenindex eq '' or $userindex eq '' or $passindex eq '' or $timeindex eq '') {
  424.             quitit ("Incompatible table specified for session control [files/$file/tables/$sessiontable.th].", 1);
  425.         }
  426.  
  427.         if ($loginsession eq $session and $sessiontime > $sessioncut) {     # login was by session
  428.             # Assign new token
  429.  
  430.             $token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
  431.             $sth = $dbh->prepare("UPDATE $fileset{DBPREF}$sessiontable SET Token = ? WHERE Session = ?") || quitit ('Could not prepare statement for token update. ' . $dbh->errstr, 1);
  432.             $sth->execute($token, $session) || quitit ('Could not execute statement for token update. ' . $sth->errstr, 1);
  433.             $sth->finish;
  434.  
  435.             $dbcommitrequired = 1;
  436.         }
  437.         elsif ($logintoken eq $token and $sessiontime > $tokencut) {     # login was by token
  438.             # Assign new token, session and time
  439.  
  440.             $token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
  441.             my $oldsession = $session;
  442.             $session = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$sessionindex]});
  443.  
  444.             $sth = $dbh->prepare("UPDATE $fileset{DBPREF}$sessiontable SET Session = ?, Token = ?, Time = ? WHERE Session = ?") || quitit ('Could not prepare statement for token update. ' . $dbh->errstr, 1);
  445.             $sth->execute($session, $token, time, $oldsession) || quitit ('Could not execute statement for token update. ' . $sth->errstr, 1);
  446.             $sth->finish;
  447.  
  448.             $dbcommitrequired = 1;
  449.         }
  450.         else {     # login was by username and password
  451.  
  452.             # Delete expired session records
  453.  
  454.             $dbh->do("DELETE FROM $fileset{DBPREF}$sessiontable WHERE Time <= $tokencut AND Time <= $sessioncut") || quitit ('Could not remove expired sessions. ' . $dbh->errstr, 1);
  455.  
  456.  
  457.             # Add new session record
  458.  
  459.             $token = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$tokenindex]});
  460.             $session = DataIn ('', '[auto]', 0, $sessiontable, \@{$th[$sessionindex]});
  461.  
  462.             my $addplaceholders = '?';
  463.             for (1..$#th) {
  464.                 $addplaceholders .= ', ?';
  465.             }
  466.  
  467.             undef my @newdata;
  468.             $newdata[$sessionindex] = $session;
  469.             $newdata[$tokenindex] = $token;
  470.             $newdata[$userindex] = $loginuser;
  471.             $newdata[$passindex] = &Encrypt($loginpass);
  472.             $newdata[$timeindex] = time;
  473.             $#newdata = $#th;
  474.  
  475.             $sth = $dbh->prepare("INSERT INTO $fileset{DBPREF}$sessiontable VALUES ($addplaceholders)") || quitit ('Could not prepare statement for new session creation. ' . $dbh->errstr, 1);
  476.             $sth->execute(@newdata) || quitit ('Could not execute statement for new session creation. ' . $sth->errstr, 1);
  477.             $sth->finish;
  478.  
  479.             $dbcommitrequired = 1;
  480.         }
  481.  
  482.         # Make session info available elsewhere
  483.  
  484.         $session{user} = $loginuser;
  485.         $session{session} = $session;
  486.         $session{token} = $token;
  487.  
  488.         # Write session cookie if cookies enabled
  489.  
  490.         if ($fileset{COOKIELOGIN} eq 'On') {
  491.             my $expire = ($fileset{SESSIONLENGTH} > $fileset{TOKENLENGTH}) ? $fileset{SESSIONLENGTH} : $fileset{TOKENLENGTH};     # Suitable expiration time for cookie in minutes
  492.             my $path = "$cgiurl/datacgi";
  493.             $path =~ s/^https?:\/\/.*?\..*?\///i;
  494.             $path = "/$path";
  495.             my $setcookie = new CGI::Cookie (
  496.                 -name        => "$in{file}\_session",
  497.                 -value        => \%session,
  498.                 -expires    => "+${expire}m",
  499.                 -path        => $path
  500.             );
  501.             print "Set-Cookie: $setcookie\n";
  502.         }
  503.     }
  504. }
  505.  
  506.  
  507. # Write flood protection record if necessary
  508.  
  509. if ($floodwrite) {
  510.     for ($count = 0; $count < scalar (@newdata); $count ++) {
  511.         if ($fileset{DBSOFT} =~ /^ODBC/ and length($newdata[$count]) > 255) {
  512.             $floodhandle->bind_param($count + 1, $newdata[$count], DBI::SQL_LONGVARCHAR) or quitit ("Could not bind_param for record insertion." . $floodhandle->errstr, 1);
  513.         }
  514.         else {
  515.             $floodhandle->bind_param($count + 1, $newdata[$count]) or quitit ("Could not bind_param for record insertion." . $floodhandle->errstr, 1);
  516.         }
  517.     }
  518.     $floodhandle->execute;
  519.     $dbcommitrequired = 1;
  520.  
  521.     # If we couldn't add the record, it's probably because of a violation of the primary key uniqueness. As
  522.     # such, we use a brute force tactic and remove the primary key to try again - flood protection tables
  523.     # have a licence to cheat after all...
  524.  
  525.     local %fileset = &ReadFileSet($floodfile);
  526.  
  527.     if ($floodhandle->err) {
  528.         if ($fileset{DBSOFT} =~ /^ODBC/) {
  529.             $dbh->do(qq|ALTER TABLE $fileset{DBPREF}$floodtable DROP CONSTRAINT $fileset{DBPREF}${floodtable}_PK|);
  530.         }
  531.         else {
  532.             $dbh->do(qq|ALTER TABLE $fileset{DBPREF}$floodtable DROP PRIMARY KEY|);
  533.         }
  534.         if ($dbh->err) {     # Something else must be wrong
  535.             quitit ('Could not record request for flood protection. ' .  $dbh->errstr, 1);
  536.         }
  537.         else {
  538.             $floodhandle->execute || quitit ('Could not record request in flood protection table. ' . $floodhandle->errstr, 1);
  539.         }
  540.     }
  541.     $floodhandle->finish;
  542. }
  543.  
  544. return 1;
  545.  
  546.  
  547. # Finds pattern match alternatives for a given IP address
  548.  
  549. sub IPAlternates {
  550.  
  551. my $ipaddress = shift @_;
  552. my @components = split (/\./, $ipaddress);
  553.  
  554. # Each component in the address can be replaced with an asterisk (*) when specifying an IP pattern. As such, there are
  555. # 2**4 = 16 different patterns that the given IP address could match. We use strings of 4 bits to represent each of the
  556. # numbers from 0 to 15. Each string then represents a pattern - 0s indicating asterisks and 1s the actual number usually
  557. # in that position.
  558.  
  559. undef my @ipalts;
  560. undef my @compalts;
  561. my $bitfield = '';
  562.  
  563. for (my $count = 0; $count < 16; $count ++) {
  564.     vec ($bitfield, 0, 4) = $count;
  565.     for (0..3) {
  566.         push (@compalts, (vec ($bitfield, $_, 1)) ? $components[$_] : '*');
  567.     }
  568.     push (@ipalts, "'" . join ('.', @compalts) . "'");
  569.     undef @compalts;
  570. }
  571.  
  572. return join (', ', @ipalts);
  573.  
  574. }
  575.  
  576. }
  577.  
  578.  
  579.  
  580.  
  581. ## Read table data
  582.  
  583. sub SQLReadTable {
  584.  
  585. &DBConnect(0);    # Connect to database 
  586.  
  587. my $file = shift @_;
  588. my $table = shift @_;
  589. $firstrecord = shift @_;
  590. $firstrecord = -1 if ($firstrecord eq '');
  591. $finalrecord = shift @_;
  592. $finalrecord = -1 if ($finalrecord eq '');
  593. my $all = shift @_;     # 1 if all records should be returned
  594. my $strictrange = shift @_;     # 1 if record range should not be overridden
  595. my ($seqfield, $count);
  596.  
  597. open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
  598.     @th = <TABLEHEAD>;
  599. close TABLEHEAD;
  600.  
  601. for (0..1) { shift @th; }
  602.  
  603. $primkey = shift @th;
  604. chomp ($primkey);
  605.  
  606. for ($count = 0; $count < scalar (@th); $count ++) {
  607.     @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  608. }
  609.  
  610.  
  611. # Validate range of records to return variables (passed in URL)
  612.  
  613. 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);
  614. $sth->execute || quitit ("Could not execute calculation of number of records in <i>$table</i> table. " . $sth->errstr, 1);
  615. $totalrecords = $sth->fetchrow_array;
  616. $sth->finish;
  617.  
  618. if ($all) {
  619.     $firstrecord = 0;
  620.     $finalrecord = $totalrecords - 1;
  621.     $navfirstrecord = $firstrecord;
  622.     $navfinalrecord = $finalrecord;
  623. }
  624. else {
  625.     $firstrecord = 0 if ($firstrecord < 0 or $firstrecord > $totalrecords or $firstrecord > $finalrecord);
  626.     $navfirstrecord = $firstrecord;
  627.     $finalrecord = $totalrecords - 1 if ($finalrecord < 0 or $finalrecord < $firstrecord);
  628.  
  629.     if ($finalrecord - $firstrecord > 99) {
  630.         $finalrecord = $firstrecord + 99;
  631.     }
  632.     $navfinalrecord = $finalrecord;
  633.     $finalrecord = $totalrecords - 1 if ($finalrecord >= $totalrecords and !$strictrange);
  634. }
  635.  
  636.  
  637. # Read in datasheet
  638.  
  639. if ($firstrecord == 0) {     # Read in the number of records we need straight off
  640.     $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);
  641.     $sth->execute || quitit ("Could not read in particular table record from <i>$table</i> table. " . $sth->errstr, 1);
  642. }
  643. else {
  644.     my $direction = '';
  645.     if ($firstrecord > ($totalrecords - $finalrecord + $firstrecord) / 2) {     # Work backwards to minimise number of wasted records
  646.         $direction = 'DESC';
  647.     }
  648.     else {
  649.         $direction = 'ASC';
  650.     }
  651.  
  652.     $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);
  653.     $sth->execute || quitit ('Could not read in records from <i>$table</i> table. ' . $sth->errstr, 1);
  654.  
  655.     my (@keys, $key);
  656.     if ($direction eq 'ASC') {
  657.  
  658.         # Strip away unwanted records
  659.  
  660.         $count = 0;
  661.         while ($count < $firstrecord and $sth->fetchrow_arrayref) {
  662.             $count ++;
  663.         }
  664.  
  665.  
  666.         # Determine primary keys of desired records
  667.  
  668.         $key = $sth->fetchrow_array;
  669.         until ($count > $finalrecord or $sth->err) {
  670.             push (@keys, $key);
  671.             $count ++;
  672.             $key = $sth->fetchrow_array;
  673.         }
  674.     }
  675.     else {
  676.         # Strip away unwanted records
  677.  
  678.         $count = $totalrecords - 1;
  679.         while ($count - 1 > $finalrecord and $sth->fetchrow_arrayref) {
  680.             $count --;
  681.         }
  682.  
  683.  
  684.         # Determine primary keys of desired records
  685.  
  686.         $key = $sth->fetchrow_array;
  687.         until ($count < $firstrecord or $sth->err) {
  688.             push (@keys, $key);
  689.             $count --;
  690.             $key = $sth->fetchrow_array;
  691.         }
  692.     }
  693.     $sth->finish;
  694.  
  695.  
  696.     # Read in full records
  697.  
  698.     if (scalar (@keys) > 0) {
  699.         my $keys = '?';
  700.         for (1..$#keys) {
  701.             $keys .= ', ?';
  702.         }
  703.         $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);
  704.         $sth->execute(@keys) || quitit ('Could not read in records from <i>$table</i> table. ' . $sth->errstr, 1);
  705.     }
  706. }
  707.  
  708. LOOP: for ($count = 0; $count <= $finalrecord - $firstrecord; $count ++) {
  709.     (@{$td[$count]} = $sth->fetchrow_array) || last LOOP;
  710.  
  711.     for ($subcount = 0; $subcount < scalar (@th); $subcount ++) {
  712.         $td[$count][$subcount] = &DataOut ($td[$count][$subcount], $th[$subcount]);
  713.     }
  714. }
  715. $sth->finish;
  716. $#td = $finalrecord - $firstrecord;     # Ensure that correct range is returned
  717.  
  718. }
  719.  
  720.  
  721.  
  722.  
  723. ## Query routine
  724.  
  725. sub SQLRunQuery {
  726.  
  727. local $file = shift @_;
  728. local $query = shift @_;
  729. $firstrecord = shift @_;
  730. $firstrecord = -1 if ($firstrecord eq '');
  731. $finalrecord = shift @_;
  732. $finalrecord = -1 if ($finalrecord eq '');
  733. local $all = shift @_;
  734. local $qh;     # Query database handle
  735.  
  736. &DBConnect(0);    # Connect to database 
  737. require 'libs/querysubs.cgi';
  738.  
  739. undef %return;
  740.  
  741.  
  742. # Read in query header
  743.  
  744. open (QUERYHEAD, "files/$file/queries/$query.qh") or quitit ("Could not open query header file [datacgi/files/$file/queries/$query.qh].", 1);
  745.     @qh = <QUERYHEAD>;
  746. close QUERYHEAD;
  747.  
  748. for (0..1) { shift @qh; }
  749. chomp (@qh);
  750.  
  751. @sortby = split (/\Q[|]\E/, shift @qh);     # Save sorting information for later
  752. undef %groupby;
  753. %groupby = split (/,| /, pop (@sortby)) if (scalar (@sortby) % 2);     # For backward compatibility, assume '[|]group, by, details' may not exist at end of file line
  754.  
  755. $rawcriteria = shift @qh;     # Save criteria string for later
  756. $statsnotneeded = shift @qh;     # Save advanced options for later
  757. $randomorder = 0;     # True if random order required
  758.  
  759.  
  760. # Construct return structure skeleton
  761.  
  762. LOOP: foreach $key (@qh) {
  763.     if ($key =~ /^(\w+)\.(\w+)$/) {
  764.         if ($1 ne '' and $2 ne '' and $key !~ /^\d+\.\d+$/) {
  765.             $return{$1}{$2} = '';     # The %return hash indicates the fields we must return
  766.         }
  767.     }
  768. }
  769. foreach $table (keys %return) {
  770.     open (TABLEHEAD, "files/$file/tables/$table.th");     # Don't quit if a failed open, just carry on
  771.         @th = <TABLEHEAD>;
  772.     close TABLEHEAD;
  773.     for (0..2) { shift @th; }
  774.  
  775.     for ($count = 0; $count < scalar (@th); $count ++) {
  776.         @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  777.         if (exists $return{$table}{$th[$count][0]}) {
  778.             $return{$table}{$th[$count][0]} = \@{$th[$count]};     # Save the information from each field for data processing
  779.         }
  780.     }
  781. }
  782.  
  783.  
  784. # Prepare criteria
  785. #
  786. # Simplex passes times to SQL databases as integers so as to force its own formatting. The Perl 'time' function is
  787. # treated in SQL WHERE clauses as a useful means to obtain the integer representation of the current time.
  788.  
  789. my $criteria = $rawcriteria;
  790. $criteria =~ s/\btime\b/time/ge;
  791. $criteria = &CriteriaProcess ($criteria, 1);
  792.  
  793.  
  794. # Generate SQL command
  795.  
  796. undef my %tables;
  797. undef my @fields;     # Fields for SQL query
  798.  
  799. foreach $table (keys %return) {     # Get participating tables
  800.     foreach $field (keys %{$return{$table}}) {
  801.         if (scalar (keys %groupby) and !exists $groupby{"$table.$field"}) {
  802.             push (@fields, qq|COUNT($fileset{DBPREF}$table.$field) AS "$table.$field"|);     # 'AS' required or hash may have incorrect field names
  803.         }
  804.         else {
  805.             push (@fields, qq|$fileset{DBPREF}$table.$field AS "$table.$field"|);     # 'AS' required or hash will have 'Field' keys rather than 'Table.Field'
  806.         }
  807.     }
  808. }
  809.  
  810. my $sqlcomm = 'SELECT ' . join (', ', @fields) . ' FROM ';
  811. foreach $key (keys %return) {
  812.     $sqlcomm .= "$fileset{DBPREF}$key, ";
  813. }
  814. $sqlcomm =~ s/, $//;
  815. $sqlcomm .= " WHERE ($criteria)" unless ($criteria eq '');     # We put parentheses around criteria so we can tack on join conditions without disturbing it
  816.  
  817.  
  818. # Read in foreign keys and prepare join conditions
  819.  
  820. my $keep = -1;
  821. undef my @joincomm;
  822. undef my %keys;
  823.  
  824. open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [files/$file/other/keys.dat].", 1);
  825.     while ($key = <KEYS>) {
  826.         chomp $key;
  827.         $keep = -1;     # By default, don't include this relationship in the query
  828.  
  829.         ($keys{many}, $keys{one}) = split (/\Q[|]\E/, $key);
  830.  
  831.         ($table, $field) = split (/\./, $keys{many}, 2);
  832.         $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)
  833.  
  834.         ($table, $field) = split (/\./, $keys{one}, 2);
  835.         $keep ++ if (exists $return{$table});     # Key applies to at least one table in the query
  836.  
  837.         if ($keep == 1) {
  838.             push (@joincomm, qq|$fileset{DBPREF}$keys{many} = $fileset{DBPREF}$keys{one}|);
  839.         }
  840.     }
  841. close KEYS;
  842.  
  843. if (scalar (@joincomm) > 0) {
  844.     if ($criteria eq '') {
  845.         $sqlcomm .= ' WHERE ';
  846.     }
  847.     else {
  848.         $sqlcomm .= ' AND ';
  849.     }
  850.     $sqlcomm .= join (' AND ', @joincomm);
  851. }
  852.  
  853.  
  854. # Add grouping information
  855.  
  856. if (scalar (keys %groupby)) {
  857.     $sqlcomm .= ' GROUP BY ';
  858.     foreach $field (keys %groupby) {
  859.         $sqlcomm .= qq|$fileset{DBPREF}$field, |;
  860.     }
  861.     $sqlcomm =~ s/, $//;
  862. }
  863.  
  864.  
  865. # Add sorting information
  866.  
  867. my $sortcomm = '';
  868. LOOP: for ($count = 0; $count < scalar (@sortby); $count ++) {
  869.     if ($count % 2) {
  870.         if ($sortby[$count] eq 'random') {
  871.             $randomorder = 1;
  872.             last LOOP;     # Skip out of loop, as other ordering is pointless
  873.         }
  874.         else {
  875.             $sortcomm .= ' DESC' if ($sortby[$count] =~ /dec$/);
  876.         }
  877.     }
  878.     else {
  879.         $sortcomm .= ', ' if ($count);     # Don't add comma to start of first field (ie: $count == 0)
  880.         $sortcomm .= qq|"$sortby[$count]"|;
  881.     }
  882. }
  883. $sqlcomm .= qq| ORDER BY $sortcomm| if (!$randomorder and length ($sortcomm) > 0);
  884.  
  885.  
  886. # Run query (note caching, as some advanced apps tend to repeat queries, and we don't want to prepare them again each the time)
  887.  
  888. if ($fileset{DBSOFT} =~ /^ODBC/) {     # ODBC may not return no. records on execute, -1 instead, requiring a different process here
  889.     my $recquery = $sqlcomm;
  890.     $recquery =~ s/SELECT .+? FROM/SELECT COUNT(*) FROM/;
  891.     $recquery =~ s/ ORDER BY.+$//;
  892.  
  893.     my $reccheck = $dbh->prepare($recquery) || quitit ('Could not prepare calculatation of expected number of return records. ' . $dbh->errstr, 1);
  894.     $reccheck->execute || quitit ('Could not calculate expected number of return records. ' . $reccheck->errstr, 1);
  895.     if ($reccheck->err) {
  896.         quitit ('Could not fetch expected number of return records. ' . $reccheck->errstr, 1)
  897.     }
  898.  
  899.     if (scalar (keys %groupby)) {
  900.  
  901.         # COUNT(*) gives aggregate for each group in this case, not total number of
  902.         # results. So we use brute force to count return records, with the lack of
  903.         # any more elegant method.
  904.  
  905.         $totalrecords = 0;
  906.         while ($reccheck->fetch) {
  907.             $totalrecords ++;
  908.         }
  909.     }
  910.     else {
  911.         # COUNT(*) gives total number of results in this case, so we can use
  912.         # something slightly less brute force, but still not ideal.
  913.  
  914.         ($totalrecords) = $reccheck->fetchrow_array;
  915.         $totalrecords = int ($totalrecords);
  916.     }
  917.  
  918.     $reccheck->finish;
  919.  
  920.     $qh = $dbh->prepare($sqlcomm) || quitit ('Could not prepare SQL statement for query. ' . $dbh->errstr, 1);
  921.     $qh->execute || quitit ("Could not execute <i>$query</i> query. <br><br>$sqlcomm" . $qh->errstr, 1);
  922. }
  923. else {
  924.     $qh = $dbh->prepare($sqlcomm) || quitit ('Could not prepare SQL statement for query. ' . $dbh->errstr, 1);
  925.     $totalrecords = $qh->execute || quitit ("Could not execute <i>$query</i> query. " . $qh->errstr, 1);
  926.     $totalrecords = int ($totalrecords);     # Get rid of 0E0 if no records returned
  927. }
  928.  
  929. if ($randomorder or $statsnotneeded ne 'on') {
  930.     @returns = @{$qh->fetchall_arrayref({})};
  931. }
  932.  
  933.  
  934. # Wrap up query, determine statistics etc
  935.  
  936. &QueryEnd;
  937.  
  938. $qh->finish;
  939.  
  940. }
  941.  
  942.  
  943.  
  944.  
  945. ## Add a record
  946.  
  947. sub SQLAddRecord {
  948.  
  949. my $file = shift @_;
  950. my $table = shift @_;
  951. my ($count, @in);
  952.  
  953. &DBConnect(0);    # Connect to database 
  954.  
  955. open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
  956.     my @th = <TABLEHEAD>;
  957. close TABLEHEAD;
  958. for (0..1) { shift @th; }
  959. chomp (@th);
  960. my $primkey = shift @th;
  961.  
  962. for ($count = 0; $count < scalar (@th); $count ++) {
  963.     @{$th[$count]} = split (/\Q[|]\E/, $th[$count]);
  964. }
  965.  
  966. for ($count = 0; $count < scalar (@th); $count ++) {
  967.     $in[$count] = &DataIn ('', $include{$th[$count][0]}, 0, $table, $th[$count]);
  968.     $include{$th[$count][0]} = &DataOut ($in[$count], $th[$count]);     # Saving to pass back to return page
  969. }
  970.  
  971.  
  972. # Check foreign key integrity
  973.  
  974. &CheckForeignKeys ($file, $table);
  975.  
  976.  
  977. # Add record
  978.  
  979. 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);
  980. $checkrecord->execute($in[$primkey]) || quitit ('Could not verify non-existence of record. ' . $checkrecord->errstr, 1);
  981. if ($checkrecord->fetch) {
  982.     quitit ("The $th[$primkey][0] $in[$primkey] already exists. Please enter another value.", 1);
  983. }
  984.  
  985.  
  986. my $addplaceholders = '?';
  987. for (1..$#th) {
  988.     $addplaceholders .= ', ?';
  989. }
  990.  
  991. $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);
  992.  
  993. for ($count = 0; $count < scalar (@th); $count ++) {
  994.     if ($fileset{DBSOFT} =~ /^ODBC/ and $th[$count][1] eq 'Memo' || $th[$count][2] > 255) {
  995.         $sth->bind_param($count + 1, $in[$count], DBI::SQL_LONGVARCHAR) or quitit ('Could not bind_param for record insertion. ' . $sth->errstr, 1);
  996.     }
  997.     else {
  998.         $sth->bind_param($count + 1, $in[$count]) or quitit ('Could not bind_param for record insertion. ' . $sth->errstr, 1);
  999.     }
  1000. }
  1001. $sth->execute || quitit ('Could not add record. ' . $sth->errstr, 1);
  1002. $sth->finish;
  1003. $dbcommitrequired = 1;
  1004.  
  1005. }
  1006.  
  1007.  
  1008.  
  1009.  
  1010. ## Edit a record
  1011.  
  1012. sub SQLEditRecord {
  1013.  
  1014. my $file = shift @_;
  1015. my $table = shift @_;
  1016. my $cascade = shift @_;
  1017. my ($count, @in);
  1018.  
  1019. &DBConnect(0);    # Connect to database 
  1020.  
  1021. if ($include{record} eq '') {
  1022.     quitit ('No record specified for editing.', 1);
  1023. }
  1024.  
  1025. open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
  1026.     my @th = <TABLEHEAD>;
  1027. close TABLEHEAD;
  1028.  
  1029. for (0..1) { shift @th; }
  1030. chomp (@th);
  1031. my $primkey = shift @th;
  1032.  
  1033. for ($count = 0; $count < scalar (@th); $count ++) {
  1034.     @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  1035. }
  1036.  
  1037. my $getrecord;
  1038. if ($fileset{DBSOFT} =~ /^ODBC/) {
  1039.     $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);
  1040. }
  1041. else {
  1042.     $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);;
  1043. }
  1044.  
  1045. my @record;
  1046. $getrecord->execute($include{record}) || quitit ('Could not extract record to edit. ' . $getrecord->errstr, 1);
  1047. unless (@record = $getrecord->fetchrow_array) {
  1048.     quitit ("Could not find record to edit [$include{record}].", 1);
  1049. }
  1050.  
  1051. $getrecord->finish;
  1052.  
  1053. for ($count = 0; $count < scalar (@th); $count ++) {
  1054.     $in[$count] = &DataIn ($record[$count], $include{$th[$count][0]}, 0, $table, $th[$count]);
  1055.     $include{$th[$count][0]} = &DataOut ($in[$count], $th[$count]);     # Saving to pass back to return page
  1056. }
  1057.  
  1058.  
  1059. # Check foreign key integrity
  1060.  
  1061. &CheckForeignKeys ($file, $table);
  1062.  
  1063.  
  1064. my $editplaceholders = qq|$th[0][0] = ?|;
  1065. for (1..$#th) {
  1066.     $editplaceholders .= qq|, $th[$_][0] = ?|;
  1067. }
  1068.  
  1069. 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);
  1070.  
  1071. for ($count = 0; $count < scalar (@th); $count ++) {
  1072.     if ($fileset{DBSOFT} =~ /^ODBC/ and $th[$count][1] eq 'Memo' || $th[$count][2] > 255) {
  1073.         $editrecord->bind_param($count + 1, $in[$count], DBI::SQL_LONGVARCHAR) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
  1074.     }
  1075.     else {
  1076.         $editrecord->bind_param($count + 1, $in[$count]) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
  1077.     }
  1078. }
  1079.  
  1080. $editrecord->bind_param($count + 1, $include{record}) or quitit ('Could not bind_param for record update. ' . $editrecord->errstr, 1);
  1081. $editrecord->execute || quitit ('Could not edit record. ' . $editrecord->errstr, 1);
  1082. $editrecord->finish;
  1083. $dbcommitrequired = 1;
  1084.  
  1085.  
  1086. # Cascade edit extensions
  1087. #
  1088. # A cascade edit will update all foreign keys referencing this record so that their relationships aren't broken, and
  1089. # recursively update foreign keys in records referencing them.
  1090. #
  1091.  
  1092. 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
  1093.  
  1094.     # Read in foreign keys
  1095.  
  1096.     open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [datacgifiles/$file/other/keys.dat].", 1);
  1097.         my @keys = <KEYS>;
  1098.     close KEYS;
  1099.     chomp @keys;
  1100.  
  1101.     my @cascadefields;
  1102.     for ($count = 0; $count < scalar (@keys); $count ++) {
  1103.         ($keys[$count]{many}, $keys[$count]{one}) = split (/\Q[|]\E/, $keys[$count]);
  1104.         if ($keys[$count]{one} eq "$table.$th[$primkey][0]") {
  1105.             push (@cascadefields, $keys[$count]{many});     # Our starting field(s) for cascading
  1106.         }
  1107.     }
  1108.  
  1109.     for ($count = 0; $count < scalar (@cascadefields); $count ++) {     # Cascade should only go one level deep unless primary keys are acting as foreign keys also
  1110.         for ($subcount = 0; $subcount < scalar (@keys); $subcount ++) {
  1111.             if ($keys[$subcount]{one} eq $cascadefields[$count]) {
  1112.                 push (@cascadefields, $keys[$subcount]{many});     # Add to end of cascade queue
  1113.                 splice (@keys, $subcount, 1);
  1114.                 $subcount --;
  1115.             }
  1116.         }
  1117.     }
  1118.  
  1119.     my $editrecord;
  1120.     for ($count = 0; $count < scalar (@cascadefields); $count ++) {
  1121.         ($table, $field) = split (/\./, $cascadefields[$count]);
  1122.         $editrecord = $dbh->prepare(qq|UPDATE $fileset{DBPREF}$table SET $field = ? WHERE $field = ?|);
  1123.         $editrecord->execute($in[$primkey], $include{record});
  1124.         if ($editrecord->err) {
  1125.             $editrecord->finish;
  1126.             quitit ('Cascade edit through tables failed. ' . $sth->errstr, 1);
  1127.         }
  1128.         $editrecord->finish;
  1129.         $dbcommitrequired = 1;
  1130.     }
  1131. }
  1132.  
  1133. }
  1134.  
  1135.  
  1136.  
  1137.  
  1138. ## Delete a record
  1139.  
  1140. sub SQLDeleteRecord {
  1141.  
  1142. $file = shift @_;
  1143. $table = shift @_;
  1144. $cascade = shift @_;
  1145. my ($count, @in, @th, @primkey, @fileindexes);
  1146.  
  1147. &DBConnect(0);    # Connect to database 
  1148.  
  1149. if ($include{record} eq '') {
  1150.     quitit ('No record specified for deletion.', 1);
  1151. }
  1152.  
  1153. open (TABLEHEAD, "files/$include{file}/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$include{file}/tables/$table.th].", 1);
  1154.     @{$th{$table}} = <TABLEHEAD>;
  1155. close TABLEHEAD;
  1156.  
  1157. for (0..1) { shift @{$th{$table}}; }
  1158. $primkey{$table} = shift @{$th{$table}};
  1159. chomp $primkey{$table};
  1160.  
  1161. my %fileindexes;
  1162. for ($count = 0; $count < scalar (@{$th{$table}}); $count ++) {
  1163.     @{$th{$table}[$count]} = split (/\Q[|]/, $th{$table}[$count]);
  1164.     if ($th{$table}[$count][1] eq 'File') {
  1165.         push (@{$fileindexes{$table}}, $count);
  1166.     }
  1167. }
  1168.  
  1169. 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);
  1170. my $numaffected = $getrecord->execute($include{record}) || quitit ('Could not extract record to delete. ' . $getrecord->errstr, 1);
  1171. if ($numaffected == 0) {
  1172.     quitit ("Could not find record to delete [$include{record}].", 1);
  1173. }
  1174.  
  1175. my @record = $getrecord->fetchrow_array;
  1176. $getrecord->finish;
  1177.  
  1178. for ($count = 0; $count < scalar (@{$th{$table}}); $count ++) {
  1179.     $include{$th{$table}[$count][0]} = &DataOut ($record[$count], $th{$table}[$count]);     # Saving to pass back to return page
  1180. }
  1181.  
  1182.  
  1183.  
  1184. # The record has been blanked, so clear out its file upload directory slots...
  1185.  
  1186. my ($index, $datafile, @files);
  1187. foreach $index (@{$fileindexes{$table}}) {
  1188.     if ($record[$index] ne '') {
  1189.         opendir (FILEDIR, "files/$file/tables/files/$record[$index]");
  1190.             @files = readdir (FILEDIR);
  1191.         closedir FILEDIR;
  1192.         for (0..1) { shift (@files); }
  1193.  
  1194.         foreach $datafile (@files) {
  1195.             unlink ("files/$file/tables/files/$record[$index]/$datafile");     # Remove all files in the directory slot
  1196.         }
  1197.         rmdir ("files/$file/tables/files/$record[$index]");     # Remove the directory slot itself
  1198.     }
  1199. }
  1200.  
  1201. 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);
  1202. $deleterecord->execute($include{record}) || quitit ('Could not extract record to delete. ' . $deleterecord->errstr, 1);
  1203. $deleterecord->finish;
  1204. $dbcommitrequired = 1;
  1205.  
  1206.  
  1207. # Cascade delete extensions
  1208. #
  1209. # A cascade delete will delete all records with foreign keys referencing this record, and recursively delete those
  1210. # pointing to them.
  1211. #
  1212.  
  1213. if ($cascade) {
  1214.  
  1215.     # Read in foreign keys
  1216.  
  1217.     open (KEYS, "files/$file/other/keys.dat") or quitit ("Could not open foreign keys file [datacgi/files/$file/other/keys.dat].", 1);
  1218.         my @keys = <KEYS>;
  1219.     close KEYS;
  1220.     chomp @keys;
  1221.  
  1222.     my (@cascadefields, %coveredkeys);
  1223.     for ($count = 0; $count < scalar (@keys); $count ++) {
  1224.         ($keys[$count]{manyfield}, $keys[$count]{onefield}) = split (/\Q[|]\E/, $keys[$count]);
  1225.         ($keys[$count]{manytable}, $keys[$count]{manyfield}) = split (/\./, $keys[$count]{manyfield}, 2);
  1226.         ($keys[$count]{onetable}, $keys[$count]{onefield}) = split (/\./, $keys[$count]{onefield}, 2);
  1227.  
  1228.         if ($keys[$count]{onetable} eq $table) {
  1229.             push (@cascadefields, $count);     # Our starting field(s) for cascading
  1230.             $coveredkeys{"key$count"} = 1;     # Indicates key has been followed (avoid infinite loops when two tables refer to each other)
  1231.         }
  1232.     }
  1233.  
  1234.     for ($count = 0; $count < scalar (@cascadefields); $count ++) {
  1235.         for ($subcount = 0; $subcount < scalar (@keys); $subcount ++) {
  1236.             if (!exists $coveredkeys{"key$subcount"} and $keys[$subcount]{onetable} eq $keys[$cascadefields[$count]]{manytable}) {
  1237.                 push (@cascadefields, $subcount);     # Add index of this key to cascade queue
  1238.                 $coveredkeys{"key$subcount"} = 1;     # Indicates key has been followed (avoid infinite loops when two tables refer to each other)
  1239.             }
  1240.         }
  1241.     }
  1242.  
  1243.     my %delkeys;
  1244.     push (@{$delkeys{$table}}, $include{record});     # Record primary key of main deleted record
  1245.  
  1246.     for ($count = 0; $count < scalar (@cascadefields); $count ++) {
  1247.         $table = \$keys[$cascadefields[$count]]{manytable};     # For clarity
  1248.  
  1249.         # Read in table header if necessary
  1250.  
  1251.         if (!exists $th{$$table}) {
  1252.             open (TABLEHEAD, "files/$include{file}/tables/$$table.th") or quitit ("Could not open table header file [datacgi/files/$include{file}/tables/$$table.th].", 1);
  1253.                 @{$th{$$table}} = <TABLEHEAD>;
  1254.             close TABLEHEAD;
  1255.  
  1256.             for (0..1) { shift @{$th{$$table}}; }
  1257.             $primkey{$$table} = shift @{$th{$$table}};
  1258.             chomp $primkey{$$table};
  1259.  
  1260.             for ($subcount = 0; $subcount < scalar (@{$th{$$table}}); $subcount ++) {
  1261.                 @{$th{$$table}[$subcount]} = split (/\Q[|]/, $th{$$table}[$subcount]);
  1262.                 if ($th{$$table}[$subcount][1] eq 'File') {
  1263.                     push (@{$fileindexes{$$table}}, $subcount);
  1264.                 }
  1265.             }
  1266.         }
  1267.  
  1268.  
  1269.         # Delete files
  1270.  
  1271.         my $inkeys = '';
  1272.         if (scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) > 0) {
  1273.             $inkeys = '?';
  1274.             for (1..scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) - 1) {
  1275.                 $inkeys .= ', ?';
  1276.             }
  1277.             $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);
  1278.             $sth->execute(@{$delkeys{$keys[$cascadefields[$count]]{onetable}}});
  1279.  
  1280.             if ($sth->err) {
  1281.                 quitit ('Could not delete file upload slots. ' . $sth->errstr, 1);
  1282.             }
  1283.  
  1284.             while ($record = $sth->fetchrow_arrayref) {
  1285.                 if ($th{$$table}[$primkey{$$table}][1] =~ /AutoInteger/) {     # Special consideration for keeping leading zeroes in AutoInteger fields
  1286.                     push (@{$delkeys{$$table}}, sprintf ("%0$th{$$table}[$primkey{$$table}][2]d", $$record[$primkey{$$table}]));
  1287.                 }
  1288.                 else {
  1289.                     push (@{$delkeys{$$table}}, $$record[$primkey{$$table}]);
  1290.                 }
  1291.                 foreach $index (@{$fileindexes{$$table}}) {
  1292.                     if ($$record[$index] ne '') {
  1293.                         opendir (FILEDIR, "files/$include{file}/tables/files/$$record[$index]");
  1294.                             @files = readdir (FILEDIR);
  1295.                         closedir FILEDIR;
  1296.                         for (0..1) { shift (@files); }
  1297.  
  1298.                         foreach $file (@files) {
  1299.                             unlink ("files/$include{file}/tables/files/$$record[$index]/$file");     # Remove all files in the directory slot
  1300.                         }
  1301.                         rmdir ("files/$include{file}/tables/files/$$record[$index]");     # Remove the directory slot itself
  1302.                     }
  1303.                 }
  1304.             }
  1305.             $sth->finish;
  1306.         }
  1307.     }
  1308.  
  1309.     my $deletekeys = 0;
  1310.     for ($count = 0; $count < scalar (@cascadefields); $count ++) {
  1311.         if (scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) > 0) {
  1312.             $deletekeys = '?';
  1313.             for (1..scalar (@{$delkeys{$keys[$cascadefields[$count]]{onetable}}}) - 1) {
  1314.                 $deletekeys .= ', ?';
  1315.             }
  1316.  
  1317.             $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);
  1318.             $sth->execute(@{$delkeys{$keys[$cascadefields[$count]]{onetable}}});
  1319.             if ($sth->err) {
  1320.                 $sth->finish;
  1321.                 quitit ('Cascade delete through tables failed. ' . $sth->errstr, 1);
  1322.             }
  1323.             $sth->finish;
  1324.             $dbcommitrequired = 1;
  1325.         }
  1326.     }
  1327. }
  1328.  
  1329. }
  1330.  
  1331.  
  1332.  
  1333.  
  1334. ## Retrieves a specified record from a specified table
  1335.  
  1336. # Reads a record into the %record hash
  1337.  
  1338. sub SQLGetRecord {
  1339.  
  1340. &DBConnect(0);    # Connect to database 
  1341.  
  1342. my $file = shift @_;
  1343. my $table = shift @_;
  1344. my $recordprimkey = shift @_;
  1345.  
  1346. open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open table header file [datacgi/files/$file/tables/$table.th].", 1);
  1347.     @th = <TABLEHEAD>;
  1348. close TABLEHEAD;
  1349.  
  1350. for (0..1) { shift @th; }
  1351. $primkey = shift @th;
  1352. chomp $primkey;
  1353.  
  1354. for ($count = 0; $count < scalar (@th); $count ++) {
  1355.     @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  1356. }
  1357.  
  1358. undef %record;
  1359. my @record;
  1360.  
  1361. $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);
  1362. $sth->execute($recordprimkey) || quitit ('Could not find specified record. ' . $sth->errstr, 1);
  1363. my $temprecord = $sth->fetchrow_arrayref;
  1364. unless ($temprecord) {
  1365.     quitit ("Could not find specified record [$recordprimkey].", 1);
  1366. }
  1367. $sth->finish;
  1368.  
  1369. for ($count = 0; $count < scalar (@{$temprecord}); $count ++) {     # Put in form $record{'Table.field'}
  1370.     $record{"$table.$th[$count][0]"} = &DataOut ($$temprecord[$count], $th[$count]);
  1371. }
  1372.  
  1373. }
  1374.  
  1375.  
  1376.  
  1377.  
  1378. ## Sends e-mail to recipients in a system table
  1379.  
  1380. sub SQLSendEmailTable {
  1381.  
  1382. # Read in table header
  1383.  
  1384. &DBConnect(0);    # Connect to database 
  1385.  
  1386. open (TABLEHEAD, "files/$file/tables/$table.th") or quitit ("Could not open IP restriction table [$file/tables/$table.th].", 1);
  1387.     @th = <TABLEHEAD>;
  1388. close TABLEHEAD;
  1389. for (0..2) { shift @th; }
  1390.  
  1391. LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
  1392.     @{$th[$count]} = split (/\Q[|]/, $th[$count]);
  1393.     if ($th[$count][0] =~ /^Email$/i) {
  1394.         $emailindex = $count;
  1395.     }
  1396. }
  1397. if ($emailindex eq '') {
  1398.     quitit ("Incompatible table specified for e-mail address list [files/$file/tables/$table.th].", 1);
  1399. }
  1400.  
  1401. undef my @emails;
  1402. for ($count = 0; $count < scalar (@templates); $count ++) {
  1403.     if ($templates[$count]{BccBulk}) {     # Send this message by Bcc bulk method
  1404.  
  1405.         # Read in e-mail addresses
  1406.  
  1407.         unless (scalar (@emails) > 0) {     # E-mails may already be read in
  1408.             @emails = @{$dbh->selectcol_arrayref(qq|SELECT $th[$emailindex][0] FROM $fileset{DBPREF}$table|)};
  1409.             quitit ("Could not retrieve e-mail addresses from <i>$table</i> table. " . $dbh->errstr, 1) if ($dbh->err);
  1410.         }
  1411.  
  1412.  
  1413.         # Ensure single line ending on message
  1414.  
  1415.         chomp $templates[$count]{$messagefield};
  1416.         $templates[$count]{$messagefield} .= "\n";
  1417.  
  1418.  
  1419.         # Prepare Bcc value
  1420.  
  1421.         $templates[$count]{$bccfield} .= ', ' if ($templates[$count]{$bccfield} ne '');
  1422.         $templates[$count]{$bccfield} .= join (', ', @emails);
  1423.  
  1424.  
  1425.         # Construct mail and send
  1426.         # (and now would be a good time to fork!)
  1427.  
  1428.         # Note subtlety here:
  1429.         # 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.
  1430.         # 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.
  1431.  
  1432.         if (!$filelock or !fork) {     # Fork off child process if possible, so we can zombie it and not have to sit it out
  1433.  
  1434.             if ($filelock and $dbconnected) {     # Don't want child to kill off DB handle
  1435.                 $dbh->{InactiveDestroy} = 1;
  1436.             }
  1437.  
  1438.             if ($sendmail) {
  1439.                 # Prepare Bcc value
  1440.  
  1441.                 my $headnum = 0;     # Max of 32768 chars in e-mail header, so may need to split Bcc bulk across several e-mails
  1442.                 $templates[$count]{$bccfield}[$headnum] = $templates[$count]{$bccfield};
  1443.  
  1444.                 for ($subcount = 0; $subcount < scalar (@emails); $subcount ++) {
  1445.                     $templates[$count]{$bccfield}[$headnum] .= qq|, $emails[$subcount]|;
  1446.                     if (length ($templates[$count]{$bccfield}[$headnum]) > 28000) {
  1447.                         $templates[$count]{$bccfield}[$headnum] =~ s/^, //;
  1448.                         $headnum ++;
  1449.                     }
  1450.                 }
  1451.                 $templates[$count]{$bccfield}[$headnum] =~ s/^, //;
  1452.  
  1453.  
  1454.                 # Send
  1455.  
  1456.                 for ($subcount = 0; $subcount <= $headnum; $subcount ++) {
  1457.                     open (SENDMAIL, "| $sendmailurl -t") or quitit ('Could not pipe to sendmail program.', 1);
  1458.                         print SENDMAIL qq|Content-type: text/html\n| if ($templates[$count]{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
  1459.                         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|;
  1460.                         print SENDMAIL wrapit ($templates[$count]{$messagefield});
  1461.                     close SENDMAIL;
  1462.  
  1463.                     &LogEmail ($templates[$count], $subcount);
  1464.                 }
  1465.             }
  1466.             else {
  1467.                 $templates[$count]{$bccfield} .= ', ' if ($templates[$count]{$bccfield} ne '');
  1468.                 $templates[$count]{$bccfield} .= join (', ', @emails);
  1469.  
  1470.                 $smtp->mail($templates[$count]{$fromfield}) or quitit ('SMTP sender command failure.', 1);
  1471.  
  1472.                 if ($templates[$count]{$tofield} ne '') {
  1473.                     $smtp->recipient(qq|$templates[$count]{$tofield}|) or quitit ('SMTP recipient command failure.', 1);
  1474.                 }
  1475.  
  1476.                 for ($subcount = 0; $subcount < scalar (@emails); $subcount ++) {
  1477.                     if ($emails[$subcount] ne '') {
  1478.                         $smtp->recipient($emails[$subcount]) or quitit ('SMTP recipient command failure.', 1);
  1479.                     }
  1480.                 }
  1481.  
  1482.                 $smtp->data();
  1483.                 $smtp->datasend(qq|Content-type: text/html\n|) if ($templates[$count]{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
  1484.                 $smtp->datasend(qq|From: "$templates[$count]{$fromnamefield}" <$templates[$count]{$fromfield}>\n|) or quitit ('SMTP From header failure. ' . $smtp->message, 1);
  1485.                 $smtp->datasend(qq|To: "$templates[$count]{$tonamefield}" <$templates[$count]{$tofield}>\n|) or quitit ('SMTP To header failure. ' . $smtp->message, 1);
  1486.                 $smtp->datasend("Cc: $templates[$count]{$ccfield}\n") or quitit ('SMTP Cc header failure. ' . $smtp->message, 1);
  1487.                 $smtp->datasend("Bcc: $templates[$count]{$bccfield}\n") or quitit ('SMTP  Bcc header failure. ' . $smtp->message, 1);
  1488.                 $smtp->datasend("Subject: $templates[$count]{$subjectfield}\n") or quitit ('SMTP Subject header failure. ' . $smtp->message, 1);
  1489.                 $smtp->datasend("\n") or quitit ('SMTP data send failure. ' . $smtp->message, 1);
  1490.                 $smtp->datasend(wrapit ($templates[$count]{$messagefield})) or quitit ('SMTP data send failure. ' . $smtp->message, 1);
  1491.                 $smtp->dataend();
  1492.  
  1493.                 &LogEmail ($templates[$count]);
  1494.             }
  1495.             if ($filelock) {     # Terminate the child if a fork
  1496.                 exit;
  1497.             }
  1498.         }
  1499.     }
  1500.     else {     # Send messages one at a time, as each has customisations
  1501.  
  1502.         $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);
  1503.         $sth->execute || quitit ('Could not retrieve e-mail address list. ' . $sth->errstr, 1);
  1504.  
  1505.         if (!$filelock or !fork) {     # Fork off child process if possible, so we can zombie it and not have to sit it out
  1506.  
  1507.             if ($filelock and $dbconnected) {     # Don't want child to kill off DB handle
  1508.                 $dbh->{InactiveDestroy} = 1;
  1509.             }
  1510.  
  1511.             while (@record = $sth->fetchrow_array) {
  1512.                 %temptemplate = %{$templates[$count]};
  1513.                 for ($subcount = 0; $subcount < scalar (@th); $subcount ++) {
  1514.                     $record[$subcount] = &DataOut ($record[$subcount], $th[$subcount]);
  1515.                     foreach $key (keys %temptemplate) {
  1516.                         $temptemplate{$key} =~ s/<!--$key-->/$record[$subcount]/ig unless ($record[$subcount] eq '');
  1517.                     }
  1518.                     if ($th[$subcount][0] =~ /^Email$/i) {
  1519.                         $temptemplate{$bccfield} .= "; $record[$subcount]";
  1520.                         $temptemplate{$bccfield} =~ s/^; //;
  1521.                     }
  1522.                 }
  1523.  
  1524.                 foreach $key (keys %temptemplate) {
  1525.  
  1526.                     # Repeat general replacements to catch any nested comment tags
  1527.  
  1528.                     &ReplaceGlobal (\$temptemplate{$key});
  1529.                     &ReplaceFormInput (\$temptemplate{$key});
  1530.                     &ReplaceIncludeInput (\$temptemplate{$key});
  1531.                     &ReplaceFileSpecific (\$temptemplate{$key}, $file, '');
  1532.                     &ReplaceCode (\$temptemplate{$key}, 1);
  1533.                     &ConditionalCheck (\$temptemplate{$key});
  1534.  
  1535.                     &StripTags (\$temptemplate{$key});
  1536.                 }
  1537.  
  1538.  
  1539.                 # Construct mail and send
  1540.  
  1541.                 if ($sendmail) {
  1542.                     open (SENDMAIL, "| $sendmailurl -t") or quitit ('Could not pipe to sendmail program.', 1);
  1543.                         print SENDMAIL qq|Content-type: text/html\n| if ($temptemplate{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
  1544.                         print SENDMAIL qq|From: "$temptemplate{$fromnamefield}" <$temptemplate{$fromfield}>\nTo: "$temptemplate{$tonamefield}" <$temptemplate{$tofield}>\nCc: $temptemplate{$ccfield}\nBcc: $temptemplate{$bccfield}\nSubject: $temptemplate{$subjectfield}\n\n|;
  1545.                         print SENDMAIL wrapit ($temptemplate{$messagefield});
  1546.                     close SENDMAIL;
  1547.  
  1548.                     &LogEmail (\%temptemplate);
  1549.                 }
  1550.                 else {
  1551.                     my @recipients = (split (/(?:;|,) */, $temptemplate{$tofield}), split (/(?:;|,) */, $temptemplate{$ccfield}), split (/(?:;|,) */, $temptemplate{$bccfield}));
  1552.                     $smtp->mail($temptemplate{$fromfield}) or quitit ('SMTP sender command failure.', 1);
  1553.                     $smtp->recipient(@recipients) or quitit ('SMTP recipient command failure.', 1);
  1554.                     $smtp->data();
  1555.                     $smtp->datasend(qq|Content-type: text/html\n|) if ($temptemplate{$formatfield} or $fileset{HTMLEMAIL} eq 'On');
  1556.                     $smtp->datasend(qq|From: "$temptemplate{$fromnamefield}" <$temptemplate{$fromfield}>\n|) or quitit ('SMTP From header failure. ' . $smtp->message, 1);
  1557.                     $smtp->datasend(qq|To: "$temptemplate{$tonamefield}" <$temptemplate{$tofield}>\n|) or quitit ('SMTP To header failure. ' . $smtp->message, 1);
  1558.                     $smtp->datasend("Cc: $temptemplate{$ccfield}\n") or quitit ('SMTP Cc header failure. ' . $smtp->message, 1);
  1559.                     $smtp->datasend("Bcc: $temptemplate{$bccfield}\n") or quitit ('SMTP  Bcc header failure. ' . $smtp->message, 1);
  1560.                     $smtp->datasend("Subject: $temptemplate{$subjectfield}\n") or quitit ('SMTP Subject header failure. ' . $smtp->message, 1);
  1561.                     $smtp->datasend("\n") or quitit ('SMTP data send failure. ' . $smtp->message, 1);
  1562.                     $smtp->datasend(wrapit ($temptemplate{$messagefield})) or quitit ('SMTP data send failure. ' . $smtp->message, 1);
  1563.                     $smtp->dataend();
  1564.  
  1565.                     &LogEmail (\%temptemplate);
  1566.                 }
  1567.             }
  1568.             $sth->finish;
  1569.  
  1570.             if ($filelock) {     # Terminate the child if a fork
  1571.                 exit;
  1572.             }
  1573.         }
  1574.     }
  1575. }
  1576.  
  1577. }
  1578.  
  1579.  
  1580.  
  1581.  
  1582. ## Loads primary keys from the specified table
  1583.  
  1584. sub SQLPrimKeys {
  1585.  
  1586. my $file = shift @_;
  1587. my $table = shift @_;
  1588. my $displayfield = shift @_;
  1589. my $count = 0;
  1590.  
  1591. &DBConnect(0);    # Connect to database 
  1592.  
  1593. undef @validvalues;
  1594. undef @displayvalues;
  1595. open (TABLEHEAD, "files/$file/tables/$table.th") or return 0;
  1596.     my (@th) = <TABLEHEAD>;
  1597. close TABLEHEAD;
  1598.  
  1599. for (0..1) { shift (@th); }
  1600. chomp (@th);
  1601. $primkey = shift (@th);
  1602.  
  1603. my (@primth) = split (/\Q[|]\E/, $th[$primkey]);
  1604. undef my @dispth;
  1605.  
  1606. LOOP: for ($count = 0; $count < scalar (@th); $count ++) {
  1607.     if ($th[$count] =~ /^$displayfield\[/i) {
  1608.         @dispth = split (/\Q[|]\E/, $th[$count]);
  1609.         last LOOP;
  1610.     }
  1611. }
  1612.  
  1613. if (scalar (@dispth) == 0) {
  1614.     @dispth = @primth;
  1615. }
  1616.  
  1617.  
  1618. # Read in primary keys
  1619.  
  1620. my $record = '';     # Holds a primary key value
  1621.  
  1622. $sth = $dbh->prepare (qq|SELECT $primth[0], $dispth[0] FROM $fileset{DBPREF}$table ORDER BY $dispth[0]|) || return 0;
  1623. $sth->execute || return 0;
  1624.  
  1625. while ($record = $sth->fetchrow_arrayref) {
  1626.     push (@validvalues, &DataOut ($$record[0], \@primth));
  1627.     push (@displayvalues, &DataOut ($$record[1], \@dispth));
  1628. }
  1629. $sth->finish;
  1630.  
  1631. }
  1632.  
  1633.  
  1634.  
  1635.  
  1636. ## Checks to see that a specified foreign key is valid
  1637.  
  1638. sub SQLCheckForeignKey {
  1639.  
  1640. # Returns 1 if value found, 0 if not
  1641.  
  1642. my $file = shift @_;
  1643. my $table = shift @_;
  1644. my $checkrecord = shift @_;
  1645. my $valid = 0;
  1646.  
  1647. &DBConnect(0);    # Connect to database 
  1648.  
  1649. open (CHECKTABLEHEAD, "files/$file/tables/$table.th") or return 0;
  1650.     my (@tempth) = <CHECKTABLEHEAD>;
  1651. close CHECKTABLEHEAD;
  1652.  
  1653. for (0..1) { shift (@tempth); }
  1654. $primkey = shift (@tempth);
  1655. chomp ($primkey);
  1656.  
  1657. @tempth = split (/\Q[|]\E/, $tempth[$primkey]);
  1658.  
  1659.  
  1660. # Check foreign key validity
  1661.  
  1662. my $sqlcomm = qq|SELECT $tempth[0] FROM $fileset{DBPREF}$table WHERE $tempth[0] = ?|;
  1663.  
  1664. $sth = $dbh->prepare ($sqlcomm) || quitit ('Could not prepare SQL statement for relationship integrity check. ' . $dbh->errstr, 1);
  1665. $valid = $sth->execute($checkrecord) || quitit ('Could not execute SQL statement for relationship integrity check. ' . $dbh->errstr, 1);
  1666. $valid = ($sth->fetch) ? 1 : 0;
  1667. $sth->finish;
  1668.  
  1669. return int ($valid);     # int() required to ensure that "0E0" returned by "execute" when 0 rows affected is interpreted as false
  1670.  
  1671. }
  1672.  
  1673.  
  1674.  
  1675.  
  1676. ## Returns the order of fields for an SQL SELECT statement
  1677.  
  1678. sub FieldOrder {
  1679.     my $thref = shift @_;
  1680.     my $count = 0;
  1681.     my @fieldorder;
  1682.  
  1683.     for ($count = 0; $count < scalar (@{$thref}); $count ++) {
  1684.         push (@fieldorder, qq|$$thref[$count][0]|);
  1685.     }
  1686.     return join (', ', @fieldorder);
  1687. }
  1688.  
  1689.  
  1690.  
  1691.  
  1692. ## Connect to database
  1693.  
  1694. sub DBConnect {
  1695.  
  1696. # Allows us to centralise database connection settings
  1697.  
  1698. unless ($dbconnected) {
  1699.     $autocommit = (shift @_) ? 1 : 0;
  1700.  
  1701.     if ($fileset{DBSOFT} eq 'mysql') {     # Some databases don't support transactions and must autocommit
  1702.         $autocommit = 1;
  1703.     }
  1704.  
  1705.     my $dbsoft = $fileset{DBSOFT};
  1706.     $dbsoft =~ s/,.*$//g;     # Removes descriptive part from driver name (eg: "ODBC, Microsoft Access" -> "ODBC")
  1707.  
  1708.     if ($dbsoft eq 'mysql') {
  1709.         $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);
  1710.     }
  1711.     else {
  1712.         $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);
  1713.     }
  1714.     undef $!;
  1715.  
  1716.     $dbconnected = 1;
  1717. }
  1718.  
  1719. }
  1720.  
  1721.  
  1722.  
  1723.  
  1724. ## Commit changes to database
  1725.  
  1726. sub DBCommit {
  1727.     $dbh->commit if ($dbconnected and !$autocommit);
  1728. }
  1729.  
  1730.  
  1731. ## Roll back changes to database
  1732.  
  1733. sub DBRollback {
  1734.     $dbh->rollback if ($dbconnected and !$autocommit);
  1735. }
  1736.  
  1737.  
  1738. ## Disconnect from database
  1739.  
  1740. sub DBDisconnect {
  1741.  
  1742.     # Allows us to centralise database disconnect process
  1743.  
  1744.     &DBCommit;
  1745.     $dbh->disconnect if ($dbconnected);
  1746.     $dbconnected = 0;
  1747. }
  1748.  
  1749.  
  1750.  
  1751.  
  1752. ## Layer Simplex data types to SQL types
  1753.  
  1754. sub CoreDataType {
  1755.  
  1756. my $datatype = shift @_;
  1757. my $size = shift @_;
  1758.  
  1759. if (scalar (keys %lowerlayer) < 1) {
  1760.  
  1761.     # MySQL data types
  1762.  
  1763.     if ($fileset{DBSOFT} eq 'mysql') {
  1764.         %lowerlayer = (
  1765.             'Text' => 'VARCHAR',
  1766.             'Memo' => 'TEXT',
  1767.             'Number' => 'REAL',
  1768.             'Integer' => 'INTEGER',
  1769.             'Counter' => 'INTEGER',
  1770.             'AutoInteger (Seq)' => 'INTEGER',
  1771.             'AutoInteger (Ran)' => 'INTEGER',
  1772.             'Date' => 'INTEGER',
  1773.             'Time' => 'INTEGER',
  1774.             'True/False' => 'TINYINT',
  1775.             'Email' => 'VARCHAR',
  1776.             'URL', => 'VARCHAR',
  1777.             'IP Address' => 'VARCHAR',
  1778.             'Handle' => 'CHAR',
  1779.             'File' => 'CHAR',
  1780.             'Password' => 'VARCHAR'
  1781.         );
  1782.     }
  1783.  
  1784.     # Microsoft Access data types
  1785.  
  1786.     elsif ($fileset{DBSOFT} eq 'ODBC, Microsoft Access') {
  1787.         %lowerlayer = (
  1788.             'Text' => 'VARCHAR',
  1789.             'Memo' => 'MEMO',
  1790.             'Number' => 'REAL',
  1791.             'Integer' => 'INTEGER',
  1792.             'Counter' => 'INTEGER',
  1793.             'AutoInteger (Seq)' => 'INTEGER',
  1794.             'AutoInteger (Ran)' => 'INTEGER',
  1795.             'Date' => 'INTEGER',
  1796.             'Time' => 'INTEGER',
  1797.             'True/False' => 'INTEGER',
  1798.             'Email' => 'VARCHAR',
  1799.             'URL', => 'VARCHAR',
  1800.             'IP Address' => 'VARCHAR',
  1801.             'Handle' => 'CHAR',
  1802.             'File' => 'CHAR',
  1803.             'Password' => 'VARCHAR'
  1804.         );
  1805.     }
  1806.  
  1807.  
  1808.     # Microsoft SQL Server data types
  1809.  
  1810.     elsif ($fileset{DBSOFT} eq 'ODBC, Microsoft SQL Server') {
  1811.         %lowerlayer = (
  1812.             'Text' => 'VARCHAR',
  1813.             'Memo' => 'TEXT',
  1814.             'Number' => 'REAL',
  1815.             'Integer' => 'INTEGER',
  1816.             'Counter' => 'INTEGER',
  1817.             'AutoInteger (Seq)' => 'INTEGER',
  1818.             'AutoInteger (Ran)' => 'INTEGER',
  1819.             'Date' => 'INTEGER',
  1820.             'Time' => 'INTEGER',
  1821.             'True/False' => 'INTEGER',
  1822.             'Email' => 'VARCHAR',
  1823.             'URL', => 'VARCHAR',
  1824.             'IP Address' => 'VARCHAR',
  1825.             'Handle' => 'CHAR',
  1826.             'File' => 'CHAR',
  1827.             'Password' => 'VARCHAR'
  1828.         );
  1829.     }
  1830. }
  1831.  
  1832.  
  1833. # Returned data type depends on DBMS
  1834.  
  1835. if ($size > 255) {     # MySQL and SQL Server (at least) have a limit of 255 characters on a field, besides their special text fields
  1836.     return $lowerlayer{'Memo'};
  1837. }
  1838.  
  1839. # MySQL
  1840.  
  1841. if ($fileset{DBSOFT} eq 'mysql') {
  1842.     if ($lowerlayer{$datatype} =~ /^(?:REAL|TEXT)$/) {     # Size need not be specified
  1843.         return $lowerlayer{$datatype};
  1844.     }
  1845.     else {
  1846.         return "$lowerlayer{$datatype}($size)";
  1847.     }
  1848. }
  1849.  
  1850.  
  1851. # ODBC
  1852.  
  1853. else {
  1854.     if ($lowerlayer{$datatype} =~ /^(?:REAL|MEMO|TEXT|INTEGER|TINYINT)/) {     # Size need not be specified
  1855.         return "$lowerlayer{$datatype}";
  1856.     }
  1857.     else {
  1858.         return "$lowerlayer{$datatype}($size)";
  1859.     }    
  1860. }
  1861.  
  1862. }
  1863.  
  1864. return 1;
  1865.  
Sep 9 '10 #12

Sign in to post your reply or Sign up for a free account.

Similar topics

0
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...
4
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...
3
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...
1
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...
0
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...
14
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...
1
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...
0
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...
1
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...
0
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...
0
by: ryjfgjl | last post by:
ExcelToDatabase: batch import excel into database automatically...
0
isladogs
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...
1
isladogs
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...
0
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...
1
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)...
1
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...
1
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....
0
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...

By using Bytes.com and it's services, you agree to our Privacy Policy and Terms of Use.

To disable or enable advertisements and analytics tracking please visit the manage ads & tracking page.