File Coverage

blib/lib/DBIx/glueHTML.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


"; ";
line stmt bran cond sub pod time code
1             ##############################################################################
2             # DBI web interface Version 0.20 #
3             # Copyright 1999-2000 James Furness furn@base6.com #
4             # Created 01/05/99 Last Modified 13/05/00 #
5             ##############################################################################
6             # COPYRIGHT NOTICE #
7             # Copyright 1999-2000 James Furness . All Rights Reserved. #
8             # #
9             # This module is free software; it may be used freely and redistributed #
10             # for free providing this copyright header remains part of the module. You #
11             # may not charge for the redistribution of this module. Selling this code #
12             # without James Furness' written permission is expressly forbidden. #
13             # #
14             # This module may not be modified without first notifying James Furness #
15             # (This is to enable me to track modifications). In all #
16             # cases this copyright header should remain fully intact in all #
17             # modifications. #
18             # #
19             # This code is provided on an "As Is" basis, without warranty, expressed or #
20             # implied. The author disclaims all warranties with regard to this software, #
21             # including all implied warranties of merchantability and fitness, in no #
22             # event shall the author, James Furness be liable for any special, indirect #
23             # or consequential damages or any damages whatsoever including but not #
24             # limited to loss of use, data or profits. By using this module you agree to #
25             # indemnify James Furness from any liability that might arise from it's use. #
26             # Should this code prove defective, you assume the cost of any and all #
27             # necessary repairs, servicing, correction and any other costs arising #
28             # directly or indrectly from it's use. #
29             # #
30             # This copyright notice must remain fully intact at all times. #
31             # Use of this program or its output constitutes acceptance of these terms. #
32             # #
33             # Parts of this module are based upon mysql-lib.pl by Ron Crisco. #
34             ##############################################################################
35              
36             package DBIx::glueHTML;
37              
38             =pod
39              
40             =head1 NAME
41              
42             DBIx::glueHTML - Class for creating a CGI interface to a database
43              
44             =head1 SYNOPSIS
45              
46             use CGI;
47             use DBI;
48             use DBIx::glueHTML;
49              
50             $cgi = new CGI;
51             $dbh = DBI->connect("DBI:mysql:[DATABASE]:[HOSTNAME]","[USERNAME]","[PASSWORD]") );
52             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, "[INFOTABLE NAME]");
53              
54             # Below here is only executed if a glueHTML action was not taken, so print a menu
55              
56             print $cgi->header;
57             print "Add\n
";
58             print "Search\n";
59              
60             =head1 DESCRIPTION
61              
62             The C class allows a CGI interface to a database.
63             It enables a CGI interface to a database to be created, supporting record addition,
64             modification, deletion and searching. It provides a user friendly interface with
65             descriptions of fields provided. The field descriptions along with information on
66             whether the field is visible, hidden or excluded are extracted from a table, allowing
67             easy modification and addition of fields and tables without having to edit code.
68              
69             =head2 Features
70              
71             =over 4
72              
73             =item Simple database administration
74              
75             Forms are created automatically on demand, SQL statements are generated as needed and processed.
76             The module contains enough autonomy to potentially run with only wrapper perl code placed around
77             it.
78              
79             =item Full form configuration
80              
81             Forms can be modified to add descriptions and extra information to fields, making it easy to change
82             output without having to edit code.
83              
84             =item Control
85              
86             Extensive callback procedures and configuration options allow output, password protection and logging
87             to be configured as desired.
88              
89             =item Full HTML customisation
90              
91             HTML output and table formats can be customised easily by the user.
92              
93             =back
94              
95             =cut
96              
97             $| = 1; # Flush all buffers
98             require 5.004; # Require at least perl 5.004
99              
100 1     1   10060 use strict;
  1         3  
  1         39  
101 1     1   5 use vars qw($VERSION);
  1         2  
  1         51  
102 1     1   2022 use CGI;
  1         16798  
  1         7  
103 1     1   1308 use DBI;
  0            
  0            
104              
105             $VERSION = '0.20';
106              
107             # ------------------------------------------------------------------------
108             # Class constructors/destructors
109             # ------------------------------------------------------------------------
110             =pod
111              
112             =head1 METHODS
113              
114             =head2 Main Methods
115              
116             =over 4
117              
118             =item B<$DBinterface = new DBIx::glueHTML (>I I I I<[Suppress paramcheck]>B<);>
119              
120             Constructs a new C object. You must pass a reference
121             to a CGI object which will be used to get the script's parameters and a
122             database handle (Returned from a Cconnect> function) which will
123             be used to communicate with the database. The third parameter defines the
124             name of the I which is used to determine hidden/excluded fields,
125             field names and descriptions as described below in B. After
126             initialisation, the CGI object is checked for a 'glueHTML-action' parameter.
127             If this is present, control is taken from the script and the specified action
128             is performed on the specified table. This parameter is set when an action which
129             requires further processing is in progress.
130              
131             The final parameter, suppress paramcheck, is optional and when set to 1 will
132             cause the script NOT to perform the parameter check. You MUST then call the
133             check_params function in your code or forms will not work. Overriding
134             the script in this way is not recommended unless necessary for error handler
135             or security check handler setting.
136              
137             =cut
138             sub new
139             {
140             my $proto = shift;
141             my $class = ref($proto) || $proto;
142             my $cgipkg = shift;
143             my $dbihdl = shift;
144             my $infotbl = shift;
145             my $suppresscheck = shift || 0;
146              
147             my $self = bless {}, $class;
148              
149             $self->{CGI} = $cgipkg; # CGI package
150             $self->{DBH} = $dbihdl; # DBI database handle
151             $self->{ITABLE} = $infotbl; # Info Table name
152             $self->{ERRHDL} = undef; # Error handler
153             $self->{LOGFILE} = undef; # Log file
154             $self->{LOGCALLBACK} = undef; # Logging callback function
155             $self->{PRINTHEADER} = undef; # HTML header
156             $self->{STARTTABLE} = undef; # HTML format
157             $self->{STARTTABLEROW} = undef; # HTML format
158             $self->{PRINTTABLECELL} = undef; # HTML format
159             $self->{PRINTTABLEHEADERCELL}= undef; # HTML format
160             $self->{PRINTENDTABLEROW} = undef; # HTML format
161             $self->{PRINTEDITTABLEROW} = undef; # HTML format
162             $self->{ENDTABLE} = undef; # HTML format
163             $self->{PRINTFOOTER} = undef; # HTML footer
164             $self->{PRINTCONTENTTYPE} = 1; # Print content type or let printheader() handle things
165             $self->{USEGMTTIME} = 1; # Use GMT time or local time
166             $self->{TIMEMOD} = 0; # Add or subtract time
167             $self->{ACCESSCALLBACK} = undef; # Security check callback
168             $self->{FORMFIELDCALLBACK} = undef; # Form field change/hide callback
169              
170             if ($suppresscheck != 1) {
171             $self->check_params;
172             }
173              
174             return $self;
175             }
176              
177             sub DESTROY { }
178              
179             ##########################################################################
180             # ------------------------------------------------------------------------
181             # User-called functions
182             # ------------------------------------------------------------------------
183              
184             =pod
185              
186             =back
187              
188             =head2 Optional Methods
189              
190             Optional methods which can be called to directly jump to a script function,
191             for example to directly initiate a delete or modify on a record.
192              
193             =over 4
194              
195             =cut
196              
197             =item B B<();>
198              
199             # Check form parameters
200             $DBinterface->check_params;
201              
202             Causes the glueHTML-action parameter to be rechecked. If it contains
203             the value 'add','modify','delete' or 'search', the respective function
204             will be called ('exec_add','exec_modify','exec_delete' or 'exec_search').
205             this function is essential to the correct functioning of the interfaces
206             with two and three part forms, and is called automatically when a
207             glueHTML object is created, unless the 'suppress paramcheck' parameter
208             is set to 1.
209              
210             =cut
211              
212             sub check_params {
213             my $self = shift;
214              
215             if ($self->{CGI}->param("glueHTML-action") eq "add") {
216             $self->exec_add;
217             exit;
218             } elsif ($self->{CGI}->param("glueHTML-action") eq "modify") {
219             $self->exec_modify;
220             exit;
221             } elsif ($self->{CGI}->param("glueHTML-action") eq "delete") {
222             $self->exec_delete;
223             exit;
224             } elsif ($self->{CGI}->param("glueHTML-action") eq "search") {
225             $self->exec_search;
226             exit;
227             }
228             }
229              
230             =item B B<();>
231              
232             # Now set the 'glueHTML-table' parameter so the script knows
233             # what table to deal with
234             $cgi->param(-name=>'glueHTML-table',-value=>'mytable');
235              
236             # Now call the function
237             $DBinterface->exec_search;
238              
239             Searches the table named in the CGI parameter 'glueHTML-table'.
240             The user will be presented with a blank form with the fields of the table.
241             They press submit to search the table (Wildcards can be used). They are then
242             returned a table with a modify and delete button and the fields for each
243             record found.
244              
245             =cut
246              
247             sub exec_search {
248             my $self = shift;
249             my $table = $self->{CGI}->param("glueHTML-table");
250             my ($tablename, $name, $label, $lookup, $extrahash, $hidden, $exclude,
251             $additionalwhere) = $self->_getTableInfoHash($table);
252              
253             # Check access privs
254             $self->_checkAccess;
255              
256             if ($self->{CGI}->param('post')) {
257             my ($i, $j, %types, %params, $pri, $cursor, $sql, @row, $val, $numcols,
258             @fielddesc, @fieldtypes, @primary_keys, $content);
259            
260             $self->_printHeader("Search Results", "");
261            
262             $numcols = 0;
263            
264             # Now look up primary key fields and field types...
265             my ($desc_cursor) = $self->_execSql ("describe $table");
266             while (@fielddesc = $desc_cursor->fetchrow) {
267             $numcols++;
268            
269             # Stuff the paramaters into a hash before we delete them
270             $params{$fielddesc[0]} = $self->{CGI}->param($fielddesc[0]);
271             $types{$fielddesc[0]} = $fielddesc[1];
272             if ($fielddesc[3] eq "PRI") {
273             push @primary_keys, $fielddesc[0];
274             }
275             }
276             $desc_cursor->finish;
277             $numcols += 2; # Add Modify and Delete cols
278            
279             # now we execute the SQL, and return a list of matches
280             $cursor = $self->_execSql($self->_selectSql($table, $additionalwhere));
281            
282             # delete the current params so they don't get incorporated in the forms
283             $self->{CGI}->delete_all;
284             $self->_startTable($numcols, "Search Results");
285            
286             # now print header row
287             $self->_printStartTableRow();
288             $self->_printTableHeaderCell("Modify");
289             $self->_printTableHeaderCell("Delete");
290             for ($i=0; $i < $cursor->{NUM_OF_FIELDS}; $i++) {
291             $self->_printTableHeaderCell("$cursor->{NAME}->[$i]");
292             }
293             $self->_printEndTableRow();
294            
295             while (@row = $cursor->fetchrow_array) {
296             $self->_printStartTableRow();
297            
298             # now print the Modify Form
299             print $self->{CGI}->startform;
300             $content = "";
301             # Print the primary keys
302             for ($i=0; $i < $cursor->{NUM_OF_FIELDS}; $i++) {
303             foreach $pri (@primary_keys) {
304             if ($pri eq $cursor->{NAME}->[$i]) {
305             print "{NAME}->[$i]\" VALUE=\"$row[$i]\">";
306             }
307             }
308             }
309             # Print state tracking elements
310             print $self->{CGI}->hidden(-name => 'glueHTML-action', value => 'modify');
311             print $self->{CGI}->hidden(-name => 'glueHTML-table', value => $table);
312             $self->_printHidden; # Print any hidden elements necessary
313             $self->_printTableCell ($self->{CGI}->submit('Modify'));
314             print $self->{CGI}->endform;
315              
316             # now print the Delete Form
317             print $self->{CGI}->startform;
318             $content = "";
319             # Print the primary keys
320             for ($i=0; $i < $cursor->{NUM_OF_FIELDS}; $i++) {
321             foreach $pri (@primary_keys) {
322             if ($pri eq $cursor->{NAME}->[$i]) {
323             print "{NAME}->[$i]\" VALUE=\"$row[$i]\">";
324             }
325             }
326             }
327             # Print state tracking elements
328             print $self->{CGI}->hidden(-name => 'glueHTML-action', value => 'delete');
329             print $self->{CGI}->hidden(-name => 'glueHTML-table', value => $table);
330             $self->_printHidden; # Print any hidden elements necessary
331             $self->_printTableCell ($self->{CGI}->submit('Delete'));
332             print $self->{CGI}->endform;
333              
334             # now print the fields
335             for ($i=0; $i < $cursor->{NUM_OF_FIELDS}; $i++) {
336             my $pos = 0;
337             $val = $row[$i];
338             $val =~ s/&/&/g;
339             $val =~ s/
340             $val =~ s/>/>/g;
341            
342             # Don't print the whole of the text fields
343             if ($types{$cursor->{NAME}->[$i]} =~ "text") {
344             my ($search) = "";
345            
346             if ($search = $params{$cursor->{NAME}->[$i]}) {
347             $search =~ s/&/&/g;
348             $search =~ s/
349             $search =~ s/>/>/g;
350            
351             # Make wildcards work in highlight
352             $search =~ s/_/(.)/g;
353             $search =~ s/%/(.*)/g;
354            
355             # This chunk borrowed from plan_search.pl by Richard Smith :p
356            
357             # Find our search string in the field
358             $pos = index(lc($val), lc($search));
359            
360             # Grab the string for 100 characters before it
361             $pos = $pos - 100;
362             if ($pos < 0) {
363             $pos = 0;
364             }
365             }
366             my ($subtext) = substr($val, $pos, 300);
367            
368             # Change the search string to bold in the part of the string we're showing
369             if ($search ne "") { $subtext =~ s/($search)/$1<\/b>/gi; }
370            
371             if (length($val) > 300) { # Show truncation marks if too long
372             if ($pos < 1) {
373             $val = $subtext . "...";
374             } else {
375             $val = "..." . $subtext . "...";
376             }
377             } else {
378             $val = $subtext;
379             }
380             }
381             $self->_printTableCell ("$val  ");
382             }
383             $self->_printEndTableRow();
384             }
385             $self->_endTable();
386             $self->_printFooter;
387             exit;
388             } else {
389             # give them the form
390             $self->_form($table,"search","Search $tablename","Search $tablename","nodefaults","");
391             exit;
392             }
393             }
394              
395             =item B B<();>
396              
397             # Assume $cgi->param has been set to indicate the primary keys
398             # for the table being modified, i.e 'Primary Key Name' = 'Primary
399             # Key Value'
400              
401             # Now set the 'glueHTML-table' parameter so the script knows
402             # what table to deal with
403             $cgi->param(-name=>'glueHTML-table',-value=>'mytable');
404              
405             # Now call the function
406             $DBinterface->exec_modify;
407              
408             Modifies a record from the table named in the CGI parameter 'glueHTML-table'
409             where the CGI parameters which have the same name as a table column. For example
410             for a table called 'data' with an 'ID' column containing the primary keys for
411             that table, set the 'glueHTML-table' parameter to 'data' and set the 'ID'
412             parameter to the ID number of the record you want to modify. The user will then
413             be presented with a form containing the data in the table for them to modify.
414             They then press submit to commit the data
415              
416             =cut
417             sub exec_modify {
418             my $self = shift;
419            
420             # Check access privs
421             $self->_checkAccess;
422              
423             # Execute the modify if the user already has the form else give the user the form
424             if ($self->{CGI}->param('post')) {
425             $self->_modifyRecord($self->{CGI}->param("glueHTML-table"));
426             } else {
427             $self->_form($self->{CGI}->param("glueHTML-table"),"modify","Modify Record","Modify Record","","fill_from_table");
428             }
429             }
430              
431             =item B B<();>
432              
433             # Now set the 'glueHTML-table' parameter so the script knows
434             # what table to deal with
435             $cgi->param(-name=>'glueHTML-table',-value=>'mytable');
436              
437             # Now call the function
438             $DBinterface->exec_add;
439              
440             Adds a record to the table named in the CGI parameter 'glueHTML-table'.
441             The user will be presented with a empty form containing just the defaults for
442             the values of that table (Defined in the SQL). They then press submit to commit
443             the data to the table.
444              
445             =cut
446             sub exec_add {
447             my $self = shift;
448              
449             # Check access privs
450             $self->_checkAccess;
451              
452             if ($self->{CGI}->param('post')) {
453             $self->_insertRecord($self->{CGI}->param("glueHTML-table"));
454             } else {
455             $self->_form($self->{CGI}->param("glueHTML-table"),"add","Add Record","Add Record","","");
456             }
457             }
458              
459             =item B B<();>
460              
461             # Assume $cgi->param has been set to indicate the primary keys
462             # for the table being modified, i.e 'Primary Key Name' = 'Primary
463             # Key Value'
464              
465             # Now set the 'glueHTML-table' parameter so the script knows
466             # what table to deal with
467             $cgi->param(-name=>'glueHTML-table',-value=>'mytable');
468              
469             # Now call the function
470             $DBinterface->exec_delete;
471              
472             Deletes a record from the table named in the CGI parameter 'glueHTML-table'
473             where the CGI parameters which have the same name as a table column. For example
474             for a table called 'data' with an 'ID' column containing the primary keys for
475             that table, set the 'glueHTML-table' parameter to 'data' and set the 'ID'
476             parameter to the ID number of the record you want to delete.
477              
478             This function will output a confirmation page requiring users to confirm the delete
479             or press their browser's back button to cancel. To skip confirmation, set the 'confirm'
480             parameter to 'Y'.
481              
482             =cut
483             sub exec_delete {
484             my $self = shift;
485              
486             # Check access privs
487             $self->_checkAccess;
488              
489             # Delete the record
490             $self->_deleteRecord($self->{CGI}->param("glueHTML-table"));
491             }
492              
493             # ------------------------------------------------------------------------
494             # General support functions
495             # ------------------------------------------------------------------------
496             =pod
497              
498             =back
499              
500             =head2 Optional Customisation Methods
501              
502             Optional methods which can be called to alter the behaviour of the script
503             or enable features such as logging.
504              
505             =over 4
506              
507             =cut
508              
509             =item B B<(>IB<);>
510              
511             sub log_callback {
512             my $description = shift;
513             my $sql = shift;
514              
515             open (LOG,">>$logfile")
516             print LOG "$description (Executing $sql)";
517             close(LOG);
518             }
519             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, $table, 1);
520             $DBinterface->set_logcallback(\&log_callback);
521             $DBinterface->check_params();
522              
523             Enables logging of SQL changes to the database via the user
524             defined routine. The first parameter passed is a description,
525             such as 'Record added to mytable' and the second parameter is
526             the SQL statement which was used.
527              
528             NOTE: check_params() MUST be called or glueHTML will not function correctly.
529              
530             =cut
531             sub set_logcallback {
532             # $self &callback;
533             $_[0]->{LOGCALLBACK} = $_[1];
534             }
535              
536             =item B B<(>IB<);>
537             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, $table, 1);
538             $DBinterface->set_logfile("/usr/local/logs/mydb-log");
539             $DBinterface->check_params();
540              
541             Enables logging of SQL changes to the database automatically
542             without providing a callback. The script will open the file
543             specified, with no locking (Althoughthis might be added in
544             future). The file must be writeable to the CGI, on UNIX you
545             normally need to I. However this may
546             differ depending on your system and what operating system
547             you have.
548              
549             NOTE: check_params() MUST be called or glueHTML will not function correctly.
550              
551             =cut
552             sub set_logfile {
553             # $self $logfile;
554             $_[0]->{LOGFILE} = $_[1];
555             }
556              
557             # Internal function to log output if logging is enabled
558             sub _logEvent {
559             my $self = shift;
560             my $cmd = shift;
561             my $sql = shift;
562             my $logfile = undef;
563              
564             # If we have a callback, use it
565             if (defined $self->{LOGCALLBACK}) {
566             &{$self->{LOGCALLBACK}} ($cmd, $sql);
567             return;
568              
569             # Else output to a logfile ourselves
570             } elsif (defined $self->{LOGFILE}) {
571             $logfile = $self->{LOGFILE};
572              
573             # Else forget logging
574             } else {
575             return;
576              
577             }
578              
579             # Get and format the time
580             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
581             if ($sec < 10) { $sec = "0$sec"; }
582             if ($min < 10) { $min = "0$min"; }
583             if ($hour < 10) { $hour = "0$hour"; }
584             if ($mon < 10) { $mon = "0$mon"; }
585             if ($mday < 10) { $mday = "0$mday"; }
586             my (@months) = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
587             my ($cur_date) = "[" . $mday . "/" . $months[$mon] . "/" . $year . ":" . $hour . ":" . $min . ":" . $sec . " +0000]";
588              
589             # Open the logfile for append
590             if (! open(LOG,">>$logfile")) {
591             # Send warnings to the browser and STDERR on failure
592             warn ("Unable to open logfile $logfile for append ($!)");
593             print "WARNING: Unable to open logfile $logfile for append ($!)";
594             return;
595             }
596              
597             # Print to the logfile
598             print LOG "$cur_date $cmd" . ($sql ne "" ? " SQL: '$sql'" : "") . "\n";
599              
600             # Close the logfile
601             close (LOG);
602             }
603              
604             =item B B<(>IB<);>
605              
606             sub errorhandler {
607             my $errstr = shift;
608              
609             print "

Fatal Error

";
610             print $errstr;
611              
612             exit;
613             }
614             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, $table, 1);
615             $DBinterface->set_errorhandler(\&errorhandler);
616             $DBinterface->check_params();
617              
618             Transfers error handling in the script from the I procedure
619             to the subroutine passed as the argument. The errorhandling routine
620             should not return, and should terminate the program after the error
621             has been output.
622              
623             NOTE: check_params() MUST be called or glueHTML will not function correctly.
624              
625             =cut
626             sub set_errhandler {
627             # $self &errorhandler;
628             $_[0]->{ERRHDL} = $_[1];
629             }
630              
631             =item B B<(>IB<);>
632              
633             sub checkaccess {
634             if ($cgi->param("password") eq "letmein") { # Example security check
635             return; # Valid password - return to allow function to continue
636             } else {
637             die ("Incorrect password"); # Incorrect - die to stop execution
638             }
639             }
640             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, $table, 1);
641             $DBinterface->set_accesscallback(\&checkaccess);
642             $DBinterface->check_params();
643              
644             Enables a security check function to approve or deny access. The function is
645             called before changes to the database are made. The function should return to
646             allow an action to complete or die to terminate the program and prevent access.
647              
648             NOTE: check_params() MUST be called or glueHTML will not function correctly.
649              
650             =cut
651             sub set_accesscallback {
652             my $self = shift;
653             my $callback = shift;
654              
655             $self->{ACCESSCALLBACK} = $callback;
656             }
657              
658             # Internal function to call the user defined security check
659             sub _checkAccess {
660             my $self = shift;
661             my $callback = $self->{ACCESSCALLBACK};
662              
663             if (ref($callback) eq 'CODE') {
664             &$callback(); # nicer to perl 5.003 users
665             }
666             }
667              
668             =item B B<(>IB<);>
669              
670             sub setfieldvalue {
671             my $table = shift; # Database table name
672             my $mode = shift; # "add"/"modify"/"search"
673             my $field = shift; # Field name
674             my $value = shift; # Field value in database or form
675             my $default= shift; # Field default value
676              
677             # Additions to the News table
678             if ($table eq "news" && $mode eq "add") {
679             # If it's the UserID field
680             if ($field eq "UserID") {
681             # Hide the field and set it to the current user's ID
682             return ($userID, 1);
683             }
684              
685             # Modifications to
686             } else if ($table eq "something" && $mode eq "modify") {
687             # Something field
688             if ($field eq "something") {
689             # Do Something
690             } else if () {
691             # Do Something else
692             }
693             }
694              
695             # Etc....
696              
697             ($val, $forcehidden) = &{$self->{FORMFIELDCALLBACK}}($table, $mode, $field, $value, $default);
698              
699             # Default behaviour - CALLBACK MUST RETURN THIS FOR UNRECOGNISED TABLES/MODES
700             return (undef, 0);
701             }
702             $DBinterface = new DBIx::glueHTML ($cgi, $dbh, $table, 1);
703             $DBinterface->set_fieldvaluecallback(\&setfieldvalue);
704             $DBinterface->check_params();
705              
706             Enables the script to override data in any input form printed by the script. The
707             callback is passed the database table, the mode (add/modify), the current value
708             and the default value. The callback can then change the value of the field, and/or
709             choose to force the field to be hidden. For example a user ID field can be defaulted
710             to the currently logged on user's ID and hidden to prevent changing.
711              
712             The callback should return an array consisting of the value to be replaced or undef
713             if the value is not to be changed, and 1 to hide the field or 0 to allow the field
714             to remain visible. If no changes are to be made, (undef, 0) must be returned.
715              
716             NOTE: check_params() MUST be called or glueHTML will not function correctly.
717              
718             =cut
719             sub set_fieldvaluecallback {
720             my $self = shift;
721             my $callback = shift;
722              
723             $self->{FORMFIELDCALLBACK} = $callback;
724             }
725              
726             # Internal function to output errors and exit the program
727             sub _die {
728             my $self = shift;
729             my $errstr = shift;
730              
731             if (defined $self->{ERRHDL}) {
732             &{$self->{ERRHDL}} ($errstr);
733             }
734              
735             # Call die whether or not the user defined error handler has been called
736             # - the error is fatal and we should not get here if the user defined
737             # handler operates correctly anyway.
738             die $errstr;
739             }
740              
741             =item B B<(>IB<,> I
742              
743             $DBinterface->set_timezone(1, 0); # Set time to GMT +0000
744             $DBinterface->set_timezone(0, -5); # Set time to server time -0500
745             $DBinterface->set_timezone(1, -8); # Set time to GMT -0800
746             $DBinterface->set_timezone(0, 2); # Set time to server time +0200
747              
748             Changes the time zone used for timestamps inserted into database records. The
749             first parameter specifies whether to use GMT time or to use the server time,
750             i.e the computer running this script's internal clock. The second parameter
751             allows time to be added or subtracted in hours.
752              
753             =cut
754             sub set_timezone {
755             # $self $usegmttime;
756             $_[0]->{USEGMTTIME} = $_[1];
757             # $self $timemod;
758             $_[0]->{TIMEMOD} = $_[2];
759             }
760              
761             # ------------------------------------------------------------------------
762             # HTML formatting functions
763             # ------------------------------------------------------------------------
764             =pod
765              
766             =back
767              
768             =head2 Optional HTML Customisation Methods
769              
770             =over 4
771              
772             =item Future Additions
773              
774             In a later version, callbacks to add user defined form parameters to
775             allow state keeping such as password protection etc.
776              
777             =item B B<(>IB<,> IB<);>
778              
779             sub printheader {
780             my $title = shift;
781             my $headtext = shift;
782              
783             print $cgi->header;
784              
785             print $cgi->start_html(-title=>"$headtext");
786              
787             if ($headtext ne "") {
788             print $cgi->h3($headtext);
789             }
790             }
791             $DBinterface->set_printheader(\&printheader, 1);
792              
793             Transfers the header HTML outputting function to a user defined function
794             to allow HTML customisation. (This is printed at the top of every page
795             outputed by this module)
796              
797             The first parameter is a function reference, the second parameter is 1 to
798             allow this module to print the HTTP Content-Type header automatically, 0
799             to suppress this.
800              
801             =cut
802             sub set_printheader {
803             # $self &printheader;
804             $_[0]->{PRINTHEADER} = $_[1];
805             # $self $printcontenttype
806             $_[0]->{PRINTCONTENTTYPE} = $_[2] || 0;
807             }
808              
809             # Internal function to start the output in the user's desired style
810             sub _printHeader {
811             my $self = shift;
812             my $title = shift;
813             my $headtext = shift;
814             my ($package, $filename, $line) = caller();
815              
816             if ($self->{PRINTCONTENTTYPE} == 1) {
817             print $self->{CGI}->header;
818             }
819              
820             if (defined $self->{PRINTHEADER}) {
821             &{$self->{PRINTHEADER}} ($title, $headtext);
822             } else {
823             # Just incase it got missed
824             if ($self->{PRINTCONTENTTYPE} != 1) {
825             print $self->{CGI}->header;
826             }
827             print $self->{CGI}->start_html(-title=>"$title",
828             -bgcolor=>"#FFFFFF",
829             -text=>"#000077"
830             );
831             if ($headtext ne "") {
832             print $self->{CGI}->h3($headtext);
833             }
834             }
835              
836             print "\n\n\n";
837             }
838              
839             =item B B<(>IB<);>
840              
841             sub printfooter {
842             print $cgi->end_html;
843             }
844             $DBinterface->set_printfooter(\&printfooter);
845              
846             Transfers the footer HTML outputting function to a user defined function
847             to allow HTML customisation. (This is printed at the bottom of every
848             page outputed by this module)
849              
850             =cut
851             sub set_printfooter {
852             # $self &printfooter;
853             $_[0]->{PRINTFOOTER} = $_[1];
854             }
855              
856             # Internal function to end the output in the user's desired style
857             sub _printFooter {
858             my $self = shift;
859              
860             if (defined $self->{PRINTFOOTER}) {
861             &{$self->{PRINTFOOTER}};
862             } else {
863             print "";
864             }
865             }
866              
867             =item B B<(>IB<);>
868              
869             sub starttable {
870             my $colwidth = shift;
871             my $title = shift;
872             my $instructions = shift;
873            
874             print "
" .
875             "\n" . \n\n";
876             "

" .

877             "$title$instructions
878             }
879             $DBinterface->set_starttable(\&starttable);
880              
881             Transfers the table beginning HTML outputting function to a user defined function
882             to allow HTML customisation. (This is used to begin all tables)
883              
884             =cut
885             sub set_starttable {
886             # $self &startTable;
887             $_[0]->{STARTTABLE} = $_[1];
888             }
889              
890             # Internal function to create a table in the user's desired style
891             sub _startTable
892             {
893             my $self = shift;
894             my $colwidth = shift;
895             my $title = shift;
896             my $instructions = shift;
897              
898             if (defined $self->{STARTTABLE}) {
899             &{$self->{STARTTABLE}}($colwidth, $title, $instructions);
900             } else {
901             print "
" .
902             "\n" . \n\n"; "; row beginnings, and is not "; "; cells, and is not "; "; header cells (Usually bold), "; "; row endings, and is not "; \n"; "; \n"; ";
903             "

" .

904             "$title$instructions
905             }
906             }
907              
908             =item B B<(>IB<);>
909              
910             sub starttablerow {
911             print "
912             }
913             $DBinterface->set_starttablerow(\&starttablerow);
914              
915             Transfers the table row beginning HTML outputting function to a user defined function
916             to allow HTML customisation. (This is used to generate
917             used in printedittablerow-outputted rows)
918              
919             =cut
920             sub set_starttablerow {
921             # $self &startTableRow;
922             $_[0]->{STARTTABLEROW} = $_[1];
923             }
924              
925             # Internal function to print the start of a table row
926             sub _printStartTableRow
927             {
928             my $self = shift;
929              
930             if (defined $self->{STARTTABLEROW}) {
931             &{$self->{STARTTABLEROW}};
932             } else {
933             print "
934             }
935             }
936              
937             =item B B<(>IB<);>
938              
939             sub printtablecell {
940             my $content = shift;
941              
942             print "";
943             print $content;
944             print "
945             }
946             $DBinterface->set_printtablecell(\&printtablecell);
947              
948             Transfers the table cell printing HTML outputting function to a user defined function
949             to allow HTML customisation. (This is used to generate
950             used in printedittablerow-outputted rows)
951              
952             =cut
953             sub set_printtablecell {
954             # $self &printTableCell;
955             $_[0]->{PRINTTABLECELL} = $_[1];
956             }
957              
958             # Internal function to print a table cell
959             sub _printTableCell
960             {
961             my $self = shift;
962             my $content = shift;
963              
964             if (defined $self->{PRINTTABLECELL}) {
965             &{$self->{PRINTTABLECELL}}($content);
966             } else {
967             print "";
968             print $content;
969             print "
970             }
971             }
972              
973             =item B B<(>IB<);>
974              
975             sub printtableheadercell {
976             my $content = shift;
977              
978             print "";
979             print $content;
980             print "
981             }
982             $DBinterface->set_printtableheadercell(\&printtableheadercell);
983              
984             Transfers the table header cell printing HTML outputting function to a user defined function
985             to allow HTML customisation. (This is used to generate
986             and is not used in printedittablerow-outputted rows)
987              
988             =cut
989             sub set_printtableheadercell {
990             # $self &printTableHeaderCell;
991             $_[0]->{PRINTTABLEHEADERCELL} = $_[1];
992             }
993              
994             # Internal function to print a table header cell
995             sub _printTableHeaderCell
996             {
997             my $self = shift;
998             my $content = shift;
999              
1000             if (defined $self->{PRINTTABLEHEADERCELL}) {
1001             &{$self->{PRINTTABLEHEADERCELL}}($content);
1002             } else {
1003             print "";
1004             print $content;
1005             print "
1006             }
1007             }
1008              
1009             =item B B<(>IB<);>
1010              
1011             sub printendtablerow {
1012             print "
1013             }
1014             $DBinterface->set_printendtablerow(\&printendtablerow);
1015              
1016             Transfers the table row ending HTML outputting function to a user defined function
1017             to allow HTML customisation. (This is used to generate
1018             used in printedittablerow-outputted rows)
1019              
1020             =cut
1021             sub set_printendtablerow {
1022             # $self &printEndTableRow;
1023             $_[0]->{PRINTENDTABLEROW} = $_[1];
1024             }
1025              
1026             # Internal function to print the end of a table row
1027             sub _printEndTableRow
1028             {
1029             my $self = shift;
1030              
1031             if (defined $self->{PRINTENDTABLEROW}) {
1032             &{$self->{PRINTENDTABLEROW}};
1033             } else {
1034             print "
1035             }
1036             }
1037              
1038             =item B B<(>IB<);>
1039              
1040             sub printedittablerow {
1041             my $name = shift;
1042             my $form = shift;
1043             my $label = shift;
1044              
1045             print "
";
1046             print $name;
1047             print "
1048             print "";
1049             print $form;
1050             print "
";
1051             print $label;
1052             print "
1053             }
1054             $DBinterface->set_printedittablerow(\&printedittablerow);
1055              
1056             Transfers the edit table's row HTML outputting function to a user defined function
1057             to allow HTML customisation. (This prints a whole row without calling printendtablerow
1058             or printstarttablerow, and is used in add/modify forms)
1059              
1060             =cut
1061             sub set_printedittablerow {
1062             # $self &printEndTableRow;
1063             $_[0]->{PRINTEDITTABLEROW} = $_[1];
1064             }
1065              
1066             # Internal function to print add/modify table rows in the user's desired style
1067             sub _printEditTableRow
1068             {
1069             my $self = shift;
1070             my $name = shift;
1071             my $form = shift;
1072             my $label = shift;
1073              
1074             if (defined $self->{PRINTEDITTABLEROW}) {
1075             &{$self->{PRINTEDITTABLEROW}}($name, $form, $label);
1076             } else {
1077             print "
";
1078             print $name;
1079             print "
1080             print "";
1081             print $form;
1082             print "
";
1083             print $label;
1084             print "
1085             }
1086             }
1087              
1088             =item B B<(>IB<);>
1089              
1090             sub endtable {
1091             print "
";
1092             print "
";
1093             }
1094             $DBinterface->set_endtable(\&endtable);
1095              
1096             Transfers the table ending HTML outputting function to a user defined function
1097             to allow HTML customisation. (This is used to end all tables)
1098              
1099             =cut
1100             sub set_endtable {
1101             # $self &endTable;
1102             $_[0]->{ENDTABLE} = $_[1];
1103             }
1104              
1105             # Internal function to end a table in the user's desired style
1106             sub _endTable
1107             {
1108             my $self = shift;
1109              
1110             if (defined $self->{ENDTABLE}) {
1111             &{$self->{ENDTABLE}};
1112             } else {
1113             print "
";
1114             print "
";
1115             }
1116             }
1117              
1118             # internal function to print extra form parameters into a query string
1119             sub _printHiddenQstring {
1120             my $self = shift;
1121             my $isFirst = shift;
1122              
1123             return "";
1124             }
1125              
1126             # internal function to print extra form parameters as form elements
1127             sub _printHidden {
1128             my $self = shift;
1129             }
1130              
1131             # internal function to print a link to repeat the last action
1132             sub _repeatLink {
1133             my $self = shift;
1134            
1135             return $self->{CGI}->url . "?glueHTML-action=" . $self->{CGI}->param("glueHTML-action")
1136             . "&glueHTML-table=" . $self->{CGI}->param("glueHTML-table")
1137             . $self->_printHiddenQstring (0);
1138             }
1139              
1140             # internal function to print a back link
1141             sub _backLink {
1142             my $self = shift;
1143            
1144             return $self->{CGI}->url . $self->_printHiddenQstring (1);
1145             }
1146              
1147             # Internal function to generate forms
1148             sub _form {
1149             my $self = shift;
1150             my $table = shift;
1151             my $action = shift;
1152             my $page_title = shift;
1153             my $page_heading = shift;
1154             my $nodefaults = shift;
1155             my $fill_from_table = shift;
1156             my $instructions;
1157              
1158             if ($action eq "search") {
1159             $instructions = "
  • Use the % character to match any number of characters (Even none).\n
  • Use the _ character to match any one character.\n
  • A % is automatically appended to all strings.\n
  • You can enter just a normal wildcard character with no special meaning by typing a \\ before it, i.e \\% or \\_.
  • Leave this form blank to show EVERYTHING.
";
1160             $instructions .= "

" . $self->{CGI}->submit('Search');

1161             }
1162            
1163             $self->_printHeader($page_title, "");
1164             print $self->{CGI}->startform;
1165             $self->_startTable (2, $page_heading, $instructions);
1166            
1167             # Output the actual form...
1168             $self->_createForm($table,$nodefaults,$fill_from_table,$action);
1169            
1170             # Mode and action variables
1171             print $self->{CGI}->hidden(-name => 'post', -value => 'true');
1172             print $self->{CGI}->hidden(-name => 'glueHTML-action', -value => $action);
1173             print $self->{CGI}->hidden(-name => 'glueHTML-table', -value => $table);
1174             $self->_printHidden; # Print any hidden elements necessary
1175            
1176             print "\n\n

1177             print "
";
1178             print $self->{CGI}->submit($action eq "search" ? 'Search' : 'Submit');
1179             print "    ";
1180             print $self->{CGI}->reset('Reset');
1181             print "
1182             print $self->{CGI}->endform;
1183             $self->_endTable;
1184             $self->_printFooter;
1185             }
1186              
1187             # Internal function to allow the calling script a final chance to change field values and/or force fields hidden
1188             sub _setFormFieldValue {
1189             my $self = shift;
1190             my $table = shift;
1191             my $mode = $self->{CGI}->param("glueHTML-action");
1192             my $field = shift;
1193             my $value = shift;
1194             my $default = shift;
1195              
1196             # Default return values
1197             my $val = undef;
1198             my $forcehidden = 0;
1199              
1200             # Replace the default values
1201             if (defined $self->{FORMFIELDCALLBACK}) {
1202             ($val, $forcehidden) = &{$self->{FORMFIELDCALLBACK}}($table, $mode, $field, $value, $default);
1203             }
1204              
1205             if ($val == undef) {
1206             $val = $value || $default;
1207             }
1208              
1209             # Return
1210             return ($val, $forcehidden);
1211             }
1212              
1213             # Internal function to generate the actual form content
1214             sub _createForm {
1215             my $self = shift;
1216             my $table = shift;
1217             my $nodefaults = shift;
1218             my $fill_from_table = shift;
1219             my $action = shift;
1220              
1221             my (@fielddesc, @fields, @fieldtypes, @fielddefaults, @primary_keys, $fill_cursor, $field);
1222             my ($tablename, $names, $label, $lookup, $extrahash, $hidden, $exclude,
1223             $additionalwhere) = $self->_getTableInfoHash($table);
1224            
1225             # Get table column info
1226             my ($desc_cursor) = $self->_execSql ("describe $table");
1227             while (@fielddesc = $desc_cursor->fetchrow) {
1228             push @fields, $fielddesc[0];
1229             push @fieldtypes, $fielddesc[1];
1230             push @fielddefaults, $fielddesc[4];
1231             if ($fielddesc[3] eq "PRI") {
1232             push @primary_keys, $fielddesc[0];
1233             }
1234             }
1235             $desc_cursor->finish;
1236            
1237             # Get primary keys and print them out to allow primary key changes without losing what record
1238             # we're editing
1239             while ($field = shift @primary_keys) {
1240             my $name = "primary_key_" . $field;
1241             my $val = $self->{CGI}->param("$field");
1242             $val =~ s/\\/\\\\/g;
1243             $val =~ s/'/\\'/g;
1244             print $self->{CGI}->hidden(-name => $name, value => $val);
1245             }
1246            
1247             # Get table values if we're filling from an existing table
1248             my ($field_values);
1249             if ($fill_from_table ne "") {
1250             $fill_cursor = $self->_execSql ($self->_selectSql($table));
1251              
1252             if (! ($field_values = $fill_cursor->fetchrow_hashref)) {
1253             $self->_die("Database error $DBI::errstr while loading form values");
1254             }
1255             }
1256            
1257             fieldloop: while ($field = shift @fields) {
1258             my ($default) = shift @fielddefaults;
1259             my ($type) = shift @fieldtypes;
1260             my ($val, $max, $size);
1261             my ($itemname, $itemform, $itemlabel, $forcehidden);
1262            
1263             my $item;
1264             foreach $item (@$exclude) {
1265             if ($field eq $item) {
1266             next fieldloop;
1267             }
1268             }
1269            
1270             if ($default eq "NULL" || $nodefaults ne "") {
1271             $default = "";
1272             }
1273            
1274             # Allow the calling script to set the default value and/or force the field hidden
1275             ($val, $forcehidden) = $self->_setFormFieldValue($table, $field, ($fill_from_table ne "" ? $field_values->{$field} : $self->{CGI}->param("$field")), $default);
1276              
1277             # Force the field hidden if _setFormFieldValue sets the forcehidden flag
1278             if ($forcehidden == 1) {
1279             push (@$hidden, $field);
1280             }
1281              
1282             ($max) = $type =~ /\((.*)\)/;
1283             $size = $max < 50 ? $max : 50;
1284            
1285             if ((substr($type, 0, 10) eq 'timestamp(') && ($val eq "") && ($nodefaults eq "")) {
1286             $val = $self->_currentTime;
1287             }
1288            
1289             # Process hidden fields - Don't hide on searches to allow people to search by all fields
1290             if ($action ne "search") {
1291             foreach $item (@$hidden) {
1292             if ($field eq $item) {
1293             print $self->{CGI}->hidden(-name=>$field,value=>$val);
1294             next fieldloop;
1295             }
1296             }
1297             }
1298            
1299             if ($$names{$field} eq "") {
1300             $itemname = "$field:";
1301             } else {
1302             $itemname = $$names{$field};
1303             }
1304            
1305             if ( $$lookup{$field} ne "" ) {
1306             # make a select list based on the SQL the caller sent us
1307             if ($nodefaults ne "") {
1308             $itemform = $self->_createSelectList($field,$$lookup{$field},"","allowblank");
1309             } else {
1310             $itemform = $self->_createSelectList($field,$$lookup{$field},$val);
1311             }
1312            
1313             } elsif ($type =~ "mediumtext") {
1314             $itemform = $self->{CGI}->textarea(-'name'=>$field,
1315             'default'=>$val,
1316             'rows'=>10,
1317             'columns'=>70);
1318            
1319             } elsif ($type =~ "text") {
1320             $itemform = $self->{CGI}->textarea(-'name'=>$field,
1321             'default'=>$val,
1322             'rows'=>5,
1323             'columns'=>50);
1324            
1325             } elsif (substr($type, 0, 5) eq 'enum(') {
1326             # TODO: Too mysql specific?
1327             my $args = substr($type, 5, -1);
1328             my @list = split(/,/, $args);
1329             $itemform = "
1330            
1331             if ($nodefaults ne "" && $val eq "") {
1332             $itemform .= "
1333             }
1334            
1335             my $option;
1336             while ($option = shift @list) {
1337             if ($option =~ /^'(.*)'$/) {
1338             $option = $1;
1339             }
1340            
1341             if ($option eq "$val") {
1342             $itemform .= "
1343             } else {
1344             $itemform .= "
1345             }
1346            
1347             $itemform .= "$option\n";
1348             }
1349            
1350             $itemform .= "\n";
1351            
1352             } elsif ($$extrahash{$field} eq "encryptpassword") {
1353             $itemform = $self->{CGI}->password_field(-'name' => $field,
1354             'value' => '',
1355             'size' => $size,
1356             'maxlength' => $max);
1357             } else {
1358             $itemform = $self->{CGI}->textfield(-'name' => $field,
1359             'value' => $val,
1360             'size' => $size,
1361             'maxlength' => $max);
1362             }
1363            
1364             if ( $$label{$field} ne "" ) {
1365             $itemlabel = $$label{$field};
1366             } else {
1367             $itemlabel = "";
1368             }
1369              
1370             # Now print the HTML
1371             $self->_printEditTableRow ($itemname, $itemform, $itemlabel);
1372             }
1373            
1374             if ($fill_from_table ne "") {
1375             $fill_cursor->finish;
1376             }
1377             }
1378              
1379             # Internal function to generate select lists based on SQL statements
1380             sub _createSelectList {
1381             my $self = shift;
1382             my $field = shift;
1383             my $sql = shift;
1384             my $default = shift;
1385             my $allowblank = shift;
1386              
1387             my (@row);
1388              
1389             my ($cursor) = $self->_execSql ("$sql");
1390              
1391             my ($rettext) = "";
1392              
1393             $rettext .= "
1394             if ($allowblank ne "") {
1395             $rettext .= "
1396             }
1397              
1398             while (@row = $cursor->fetchrow) {
1399              
1400             if ($row[0] eq "$default") {
1401             # if their query returns 2 columns, use the first as the value
1402             if ($row[1] ne "") {
1403             $rettext .= "
1404             } else {
1405             $rettext .= "
1406             }
1407             } else {
1408             # if their query returns 2 columns, use the first as the value
1409             if ($row[1] ne "") {
1410             $rettext .= "
1411             } else {
1412             $rettext .= "
1413             }
1414             }
1415              
1416             # if their query returns 2 columns, use the second as the label
1417             if ($row[1] ne "") {
1418             $rettext .= "$row[1]\n";
1419             } else {
1420             $rettext .= "$row[0]\n";
1421             }
1422              
1423             }
1424              
1425             $rettext .= "\n";
1426              
1427             return $rettext;
1428             }
1429              
1430             sub _currentTime {
1431             my $self = shift;
1432             my $timemod = $self->{TIMEMOD} != 0 ? $self->{TIMEMOD} * 60 * 60 : 0;
1433             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
1434              
1435             if ($self->{USEGMTTIME} == 0) {
1436             ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time + $timemod);
1437             } else {
1438             ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time + $timemod);
1439             }
1440              
1441             $sec = $sec < 10 ? "0$sec" : $sec;
1442             $min = $min < 10 ? "0$min" : $min;
1443             $hour = $hour < 10 ? "0$hour" : $hour;
1444             $mon++;
1445             $mon = $mon < 10 ? "0$mon" : $mon;
1446             $mday = $mday < 10 ? "0$mday" : $mday;
1447             $year = $year + 1900;
1448              
1449             return("$year$mon$mday$hour$min$sec");
1450             }
1451              
1452             # ------------------------------------------------------------------------
1453             # SQL formatting and output functions
1454             # ------------------------------------------------------------------------
1455              
1456             # Internal function to execute SQL commands
1457             sub _execSql {
1458             my $self = shift;
1459             my $cmd = shift;
1460             my $sthdl;
1461              
1462             $sthdl = $self->{DBH}->prepare($cmd) || $self->_die("Database error preparing $cmd: " . $sthdl->errstr);
1463             $sthdl->execute || $self->_die("Database error executing $cmd: " . $sthdl->errstr);
1464              
1465             return $sthdl;
1466             }
1467              
1468             # Internal function to quote and escape SQL entries
1469             sub _sqlQuote {
1470             my $self = shift;
1471             my $str = shift;
1472              
1473             # Use DBI's quote method which ensures correct quoting for whatever database system is being used
1474             return $self->{DBH}->quote($str);
1475             }
1476              
1477             # Internal function to return a hash of all data from the info table
1478             sub _getTableInfoHash {
1479             # my ($package, $filename, $line) = caller();
1480             # print $line;
1481             my $self = shift;
1482             my $table = shift;
1483             my $itable = $self->{ITABLE};
1484              
1485             my $sql = "select TableName, NameHash, LabelHash, LookupHash, ExtraHash, Hidden, Exclude, AdditionalWhere from $itable where TableID = '$table'";
1486              
1487             my $cursor = $self->_execSql ($sql);
1488            
1489             my ($entry, $table_name, %namehash, %labelhash, %lookuphash, %extrahash, @hidden, @exclude, $additionalwhere);
1490              
1491             # Don't die on fail - simply return an empty hash and default everything
1492             # TODO: Protect against undefined tables for this
1493             if ($entry = $cursor->fetchrow_hashref) {
1494             my ($hashInfo, $pair, @pairs);
1495              
1496             # Load table name
1497             $table_name = $entry->{"TableName"};
1498              
1499             # Load name hash
1500             $hashInfo = $entry->{"NameHash"};
1501             @pairs = split(/&/, $hashInfo);
1502             foreach $pair (@pairs) {
1503             my ($name, $value) = split(/=/, $pair);
1504             $namehash{$name} = $value;
1505             }
1506              
1507             # Load label hash
1508             $hashInfo = $entry->{"LabelHash"};
1509             @pairs = split(/&/, $hashInfo);
1510             foreach $pair (@pairs) {
1511             my ($name, $value) = split(/=/, $pair);
1512             $labelhash{$name} = $value;
1513             }
1514              
1515             # Load lookup hash
1516             $hashInfo = $entry->{"LookupHash"};
1517             @pairs = split(/&/, $hashInfo);
1518             foreach $pair (@pairs) {
1519             my ($name, $value) = split(/=/, $pair);
1520             $lookuphash{$name} = $value;
1521             }
1522              
1523             # Load extra hash
1524             $hashInfo = $entry->{"ExtraHash"};
1525             @pairs = split(/&/, $hashInfo);
1526             foreach $pair (@pairs) {
1527             my ($name, $value) = split(/=/, $pair);
1528             $extrahash{$name} = $value;
1529             }
1530              
1531             # Load hidden array
1532             $hashInfo = $entry->{"Hidden"};
1533             @hidden = split(/&/, $hashInfo);
1534              
1535             # Load exclude array
1536             $hashInfo = $entry->{"Exclude"};
1537             @exclude = split(/&/, $hashInfo);
1538              
1539             # Load table name
1540             $additionalwhere = $entry->{"AdditionalWhere"};
1541             }
1542              
1543             $cursor->finish;
1544             return ($table_name, \%namehash, \%labelhash, \%lookuphash, \%extrahash, \@hidden, \@exclude, $additionalwhere);
1545             }
1546              
1547             # Internal function to return a hash of just the extra data from the info table
1548             sub _getTableExtraHash {
1549             my $self = shift;
1550             my $table = shift;
1551              
1552             my $cursor = $self->_execSql ('select ExtraHash from ' . $self->{ITABLE} . ' where TableID = ' . $self->_sqlQuote($table));
1553             my ($entry, %hash);
1554              
1555             # Don't die on fail - simply return an empty hash and default everything
1556             # TODO: Protect against undefined tables for this
1557             if ($entry = $cursor->fetchrow_hashref) {
1558             my $hashInfo = $entry->{"ExtraHash"};
1559              
1560             my @pairs = split(/&/, $hashInfo);
1561             my $pair;
1562              
1563             foreach $pair (@pairs) {
1564             my ($name, $value) = split(/=/, $pair);
1565              
1566             $hash{$name} = $value;
1567             }
1568             }
1569              
1570             $cursor->finish;
1571             return \%hash;
1572             }
1573              
1574             # Internal function to execute a SQL modify
1575             sub _modifyRecord {
1576             my $self = shift;
1577             my $table = shift;
1578              
1579             # Run the SQL
1580             my $sql = $self->_updateSql ($table);
1581             my $cursor = $self->_execSql ($sql);
1582             $cursor->finish;
1583              
1584             # Tell the people what we did
1585             $self->_printHeader('Modification Successful', 'Record modified successfully.');
1586             print "
    ";
1587             print "
  • _backLink . "\">Main Menu";
    • 1588             print "";
    1589             $self->_printFooter;
    1590              
    1591             # Log it, if logging is enabled
    1592             $self->_logEvent("Record modified from $table", $sql);
    1593             }
    1594              
    1595             # Internal function to execute a SQL delete
    1596             sub _deleteRecord {
    1597             my $self = shift;
    1598             my $table = shift;
    1599              
    1600             # Require confirmation of the delete
    1601             if ($self->{CGI}->param('confirm')) {
    1602             # Run the SQL
    1603             my $sql = $self->_deleteSql($table);
    1604             my $cursor = $self->_execSql ($sql);
    1605             $cursor->finish;
    1606              
    1607             # Tell the people what we did
    1608             $self->_printHeader('Deletion Successful', 'Record deleted successfully.');
    1609             print "
      ";
    1610             print "
  • _backLink . "\">Main Menu";
    • 1611             print "";
    1612             $self->_printFooter;
    1613              
    1614             # Log it, if logging is enabled
    1615             $self->_logEvent("Record deleted from $table", $sql);
    1616             } else {
    1617             # Ask them to confirm their action
    1618             $self->_printHeader('Confirm Delete', 'Confirm Delete');
    1619             print $self->{CGI}->b('Press back to cancel. Press Confirm to delete.');
    1620             print $self->{CGI}->startform;
    1621             $self->_printHidden; # Print any hidden elements necessary
    1622              
    1623             # Print all the form params as hidden fields
    1624             my @form = $self->{CGI}->param;
    1625             my $name;
    1626             while ($name = shift @form) {
    1627             print $self->{CGI}->hidden (-name=>$name, -value=>$self->{CGI}->param ($name) );
    1628             }
    1629              
    1630             print $self->{CGI}->hidden(-name=>'confirm',-value =>'true');
    1631             print $self->{CGI}->submit('Confirm');
    1632             print "   ";
    1633             print 'Cancel';
    1634             print $self->{CGI}->endform;
    1635             $self->_printFooter;
    1636             }
    1637             }
    1638              
    1639             # Internal function to execute a SQL insert
    1640             sub _insertRecord {
    1641             my $self = shift;
    1642             my $table = shift;
    1643              
    1644             # Run the SQL
    1645             my $sql = $self->_insertSql ($table);
    1646             my $cursor = $self->_execSql ($sql);
    1647             $cursor->finish;
    1648              
    1649             # Tell the people what we did
    1650             $self->_printHeader('Addition Successful', 'Record added successfully.');
    1651             print "
      ";
    1652             print "
  • _repeatLink . "\">Add Another";
    • 1653             print "
  • _backLink . "\">Main Menu";
    • 1654             print "";
    1655             $self->_printFooter;
    1656              
    1657             # Log it, if logging is enabled
    1658             $self->_logEvent("Record added to $table", $sql);
    1659             }
    1660              
    1661             # _insertSql - internal function to generate insert statements for $table, inserting all values in
    1662             # $self->{CGI}->param which match the table column names.
    1663             sub _insertSql {
    1664             my $self = shift;
    1665             my $table = shift;
    1666              
    1667             # Use a DESCRIBE statement to get the field default values
    1668             my $desc_cursor = $self->_execSql ("describe $table");
    1669             my (@fields, @fielddefaults, @fieldextra, @fielddesc);
    1670             my $fieldextra2 = $self->_getTableExtraHash($table); # Get extra info from the infotable
    1671             while (@fielddesc = $desc_cursor->fetchrow) {
    1672             push @fields, $fielddesc[0];
    1673             push @fielddefaults, $fielddesc[4];
    1674             push @fieldextra, $fielddesc[5];
    1675             }
    1676             $desc_cursor->finish;
    1677              
    1678             my $first_time = 1;
    1679             my ($field, $default, $extra);
    1680              
    1681             # Start the SQL statement
    1682             my $sql = "insert into $table values (";
    1683              
    1684             # Step through the fields and add a section to the statement for each
    1685             while ($field = shift @fields) {
    1686             $default = shift @fielddefaults;
    1687             $extra = shift @fieldextra;
    1688              
    1689             # Convert NULL fields to "" unless they are auto incrementing in which case
    1690             # leave them as NULL to allow the auto increment to function
    1691             $default = $default eq "NULL" ? "" : $default;
    1692             if ($extra eq "auto_increment") {
    1693             $default = "NULL";
    1694             }
    1695              
    1696             # Get the value if we have a CGI-specified value, else use the default
    1697             my $val = $self->{CGI}->param("$field") || $default;
    1698              
    1699             # Add commas between statements
    1700             if ($first_time != 1) {
    1701             $sql .= ', ';
    1702             }
    1703              
    1704             # Encrypt passwords if required, then add the value to the statement
    1705             if ($$fieldextra2{$field} eq "encryptpassword") {
    1706             $sql .= "PASSWORD(" . $self->_sqlQuote($val) . ")";
    1707             } else {
    1708             $sql .= $self->_sqlQuote($val);
    1709             }
    1710              
    1711             $first_time = 0;
    1712             }
    1713              
    1714             # Close the SQL statement
    1715             $sql .= ")";
    1716              
    1717             return ($sql);
    1718             }
    1719              
    1720             # _selectSql - internal function to generate select statements for $table, selecting all fields
    1721             # with a where clause based on the values in $self->{CGI}->param that match the table's column names.
    1722             # The second parameter is appended to the statement, if it is present, which can be used for
    1723             # order by clauses etc.
    1724             sub _selectSql {
    1725             my $self = shift;
    1726             my $table = shift;
    1727             my $additional = shift;
    1728              
    1729             # Use a DESCRIBE statement to get the field default values
    1730             my $desc_cursor = $self->_execSql ("describe $table");
    1731             my (@fields, @fielddesc);
    1732             while (@fielddesc = $desc_cursor->fetchrow) {
    1733             push @fields, $fielddesc[0];
    1734             }
    1735             $desc_cursor->finish;
    1736              
    1737             my $first_time = 1;
    1738             my $field;
    1739              
    1740             # Start the SQL statement
    1741             my $sql = "select * from $table ";
    1742              
    1743             # Step through the fields and add a section to the statement for each
    1744             while ($field = shift @fields) {
    1745             my $val = $self->{CGI}->param("$field");
    1746             next if (!$val);
    1747              
    1748             if ($first_time == 1) {
    1749             $sql .= 'where ';
    1750             $first_time = 0;
    1751             } else {
    1752             $sql .= 'and ';
    1753             }
    1754              
    1755             # TODO: might want to do type check here - does it matter?
    1756             # Add the SQL like statement and append a % to the value to allow part searching
    1757             $sql .= "$field like " . $self->_sqlQuote($val . "%") . " ";
    1758             }
    1759              
    1760             # Add any additional data
    1761             $sql .= $additional;
    1762              
    1763             return($sql);
    1764             }
    1765              
    1766             # _updateSql - internal function to generate update statements for $table, inserting all values in
    1767             # $self->{CGI}->param which match the table column names.
    1768             sub _updateSql {
    1769             my $self = shift;
    1770             my $table = shift;
    1771              
    1772             # Use a DESCRIBE statement to get the primary keys and field names
    1773             my $desc_cursor = $self->_execSql ("describe $table");
    1774             my (@fields, @primary_keys, @fielddesc);
    1775             my $fieldextra2 = $self->_getTableExtraHash($table); # Get extra info from the infotable
    1776             while (@fielddesc = $desc_cursor->fetchrow) {
    1777             # Skip if this is a password and no change has been requested
    1778             next if ( ($$fieldextra2{$fielddesc[0]} eq "encryptpassword") && ($self->{CGI}->param($fielddesc[0]) eq "") );
    1779              
    1780             push @fields, $fielddesc[0];
    1781             if ($fielddesc[3] eq "PRI") {
    1782             push @primary_keys, $fielddesc[0];
    1783             }
    1784             }
    1785             $desc_cursor->finish;
    1786              
    1787             my $first_time = 1;
    1788             my $field;
    1789              
    1790             # Start the SQL statement
    1791             my $sql = "update $table ";
    1792              
    1793             # Step through the fields and add a section to the statement for each
    1794             while ($field = shift @fields) {
    1795             my $val = $self->{CGI}->param("$field");
    1796             $val = $val eq "NULL" ? "" : $val;
    1797              
    1798             if ($first_time == 1) {
    1799             $sql .= 'set ';
    1800             $first_time = 0;
    1801             } else {
    1802             $sql .= ', ';
    1803             }
    1804              
    1805             # Encrypt passwords if required, then add the value to the statement
    1806             if ($$fieldextra2{$field} eq "encryptpassword") {
    1807             $sql .= $field . "=" . "PASSWORD(" . $self->_sqlQuote($val) . ") ";
    1808             } else {
    1809             $sql .= $field . "=" . $self->_sqlQuote($val) . " ";
    1810             }
    1811             }
    1812              
    1813             $first_time = 1;
    1814             while ($field = shift @primary_keys) {
    1815             my $val = $self->{CGI}->param("primary_key_$field");
    1816              
    1817             if ( $first_time) {
    1818             $sql .= 'where ';
    1819             $first_time = 0;
    1820             } else {
    1821             $sql .= 'and ';
    1822             }
    1823              
    1824             $sql .= "$field = " . $self->_sqlQuote($val) . " ";
    1825             }
    1826             if ($first_time == 1) { # this is very bad - table has no primary keys...
    1827             $self->_die("_updateSql failed - $table has no primary key set");
    1828             }
    1829              
    1830             return($sql);
    1831             }
    1832              
    1833             # _deleteSql - internal function to generate delete statements for $table, with a where clause
    1834             # based on where $self->{CGI}->param which match $table's primary key names.
    1835             sub _deleteSql {
    1836             my $self = shift;
    1837             my $table = shift;
    1838              
    1839             # Use a DESCRIBE statement to get the primary keys
    1840             my $desc_cursor = $self->_execSql ("describe $table");
    1841             my (@primary_keys, @fielddesc);
    1842             my $fieldextra2 = $self->_getTableExtraHash($table); # Get extra info from the infotable
    1843             while (@fielddesc = $desc_cursor->fetchrow) {
    1844             if ($fielddesc[3] eq "PRI") {
    1845             push @primary_keys, $fielddesc[0];
    1846             }
    1847             }
    1848             $desc_cursor->finish;
    1849              
    1850             my $first_time = 1;
    1851             my $field;
    1852              
    1853             # Start the SQL statement
    1854             my $sql = "delete from $table ";
    1855              
    1856             while ($field = shift @primary_keys) {
    1857             my $val = $self->{CGI}->param("$field");
    1858              
    1859             if ( $first_time) {
    1860             $sql .= 'where ';
    1861             $first_time = 0;
    1862             } else {
    1863             $sql .= 'and ';
    1864             }
    1865              
    1866             $sql .= "$field = " . $self->_sqlQuote($val) . " ";
    1867             }
    1868              
    1869             return($sql);
    1870             }
    1871              
    1872             1;
    1873              
    1874             __END__