File Coverage

blib/lib/HTML/DBForm/Search/TableList.pm
Criterion Covered Total %
statement 13 116 11.2
branch 0 44 0.0
condition 0 5 0.0
subroutine 4 14 28.5
pod 3 11 27.2
total 20 190 10.5


line stmt bran cond sub pod time code
1             package HTML::DBForm::Search::TableList;
2              
3 1     1   741 use strict;
  1         2  
  1         52  
4 1     1   7 use warnings;
  1         1  
  1         33  
5 1     1   5 no warnings 'uninitialized';
  1         2  
  1         2053  
6              
7              
8             our $VERSION = '1.05';
9              
10             =head1 NAME
11              
12             HTML::DBForm::Search::TableList - Creates a web interface for searching database tables
13              
14             =head1 SYNOPSIS
15              
16             $search = HTML::DBForm::Search->new('tablelist', { column => 'name' });
17            
18             $editor->run(search => $search);
19              
20              
21             =head1 INTRODUCTION
22              
23             HTML::DBForm::Search::TableList provides a web interface to search for rows
24             in a database to be updated by HTML::DBForm.
25              
26             =cut
27              
28             =head1 METHODS
29              
30             =over 4
31              
32             =cut
33              
34              
35             =head2 new
36              
37             Constructor inherited from HTML::DBForm::Search
38              
39             takes a scalar indicating the type of search module
40             to create (in this case 'tablelist'), and a list of
41             hash refs designating which columns to display as HTML
42             select form elements, and in which order.
43              
44             Each hash should have one of the following keys:
45             'column', 'columns', or 'sql'. 'column' should be the db
46             column to search, 'columns' should be two db columns, the
47             first of which will be the column to search, and the second of
48             which will be the values to display as option labels. 'sql'
49             can be used to populate the select options with an arbitrary SQL
50             statement. If one column is returned from the SQL statement, then
51             it will be used as choice values and labels. If two columns are
52             returned, then the first will be the specified column value, while
53             the second will be used as option labels.
54              
55              
56             B
57              
58             $search = HTML::DBForm::Search->new('tablelist',
59             { column => 'category' },
60             { columns => ['id', ' CONCAT(fname, ' ', lname) '] }
61             );
62              
63            
64              
65             This would create a two step search, the first screen would be a
66             selection of existing categories, and the next screen would be a
67             selection of names within the chosen categories. When picking
68             columns to display in the search, be aware that the final choice
69             should result in the primary key being chosen.
70              
71            
72             B
73              
74             $search = HTML::DBForm::Search->new('tablelist',
75             { sql => ['id','SELECT id, label FROM table ORDER BY label'] }
76             );
77              
78             This would create a simple one step search.
79              
80             You can use as many hashrefs as needed, each one will generate
81             a new search step, (e.g three hash references will create a three
82             step search). Just keep in mind that the last column chosen must be
83             the column given to DBForm->new() as a primary key.
84              
85             =cut
86              
87              
88             # implementation of this method is required
89             # constructor inherited from Class::Factory
90             # via HTML::DBForm::Search
91              
92              
93             sub init {
94              
95 1     1 0 264 my $self = shift;
96 1         8 $self->{params} = \@_;
97              
98 1         3 $self->{html_cols} = [];
99              
100 1         4 return $self;
101             }
102              
103              
104              
105             # implementation of this method is required
106             # main subroutine called by HTML::DBForm
107              
108             sub run {
109              
110 0     0 0   my ($self, $editor) = @_;
111              
112             my $tmpl_ref = $self->{'tmpl_file'}
113 0 0         ? do { open(FH, "< $self->{'tmpl_file'}"); local $/; }
  0            
  0            
  0            
114             : &TEMPLATE;
115              
116              
117 0           $self->{template} = HTML::Template->new(
118             scalarref => \$tmpl_ref,
119             die_on_bad_params => 0,
120             loop_context_vars => 1,
121             );
122              
123              
124 0           $self->{editor} = $editor;
125            
126             # find out what step we are on
127 0   0       $self->{step} = $self->{editor}->{query}->param('step') || 0;
128            
129 0           $self->{template}->param(STEP => $self->{step} + 1);
130            
131 0           $self->get_choices;
132              
133 0 0         return ($self->{editor}->{error}) ?
134             $self->{editor}->{template}->output :
135             $self->{template}->output ;
136              
137             }
138              
139              
140             =head2 set_stylesheet
141              
142             Sets an optional css file
143              
144             Takes a scalar holding the path to a stylesheet.
145              
146              
147             B
148              
149             $search->set_stylesheet('/styles/site_styles.css');
150              
151             =cut
152              
153             sub set_stylesheet {
154              
155 0     0 1   my $self = shift;
156 0           $self->{css} = shift ;
157             }
158              
159              
160              
161             =head2 set_template
162              
163             Sets an optional template file
164              
165             Takes a scalar holding the path to an HTML::Template template.
166             To get a template file to start with, you can do this:
167             perl -MHTML::DBForm::Search::DropDown -e 'print
168             HTML::DBForm::Search::DropDown::TEMPLATE()' > sample.tmpl
169              
170             B
171              
172             $search->set_template('/www/templates/my.tmpl');
173              
174             =cut
175              
176             sub set_template {
177              
178 0     0 1   my $self = shift;
179 0           $self->{tmpl_file} = shift ;
180             }
181              
182              
183              
184              
185             =head2 add_column
186              
187             Adds a new column to your search list table.
188             Only affects the last search screen.
189              
190             Required parameters:
191              
192             I the column that this form element represents
193              
194             Optional parameters:
195              
196             I
197             this will default to the name of the column.
198              
199             I a subroutine reference that will be passed each
200             value for processing before display.
201              
202             B
203            
204             $editor->add_column( column => 'date' );
205            
206             $editor->add_column(
207             column => 'fname',
208             label => 'First Name',
209             callback => sub { ucfirst(shift) }
210             );
211              
212             =cut
213              
214             sub add_column {
215            
216 0     0 1   my $self = shift;
217              
218 0 0         $self->_err_msg("add_column() got an odd number of parameters!")
219             unless ((@_ % 2) == 0);
220              
221 0           my %params = @_;
222            
223 0           push (@{$self->{td_cols}}, \%params);
  0            
224              
225             }
226              
227              
228              
229             # get choices to display
230              
231             sub get_choices {
232              
233 0     0 0   my $self = shift;
234              
235 0 0         if ($self->{params}->[$self->{step}]->{sql}){
236              
237             # use sql parameter
238 0           $self->populate_search(
239             $self->{params}->[$self->{step}]->{sql}->[1]
240             );
241              
242             } else {
243              
244             # generate our own sql
245 0           $self->populate_search(
246             $self->get_select($self->parse_params($self->{step}))
247             );
248             }
249             }
250              
251              
252              
253             # parse search parameters
254            
255             sub parse_params {
256              
257 0     0 0   my $self = shift;
258 0           my $i = shift;
259              
260 0           my $c_param = $self->{params}->[$i];
261              
262 0 0         if ($c_param->{column}){
263 0           return ($c_param->{column}, $c_param->{column});
264             }
265              
266 0 0         if ($c_param->{columns}) {
267 0           return ($c_param->{columns}->[0], $c_param->{columns}->[1]);
268             }
269              
270 0 0         if ($c_param->{sql}) {
271 0           return ($c_param->{sql}->[0], $c_param->{sql}->[1]);
272             }
273             }
274              
275              
276              
277             # build a select statement
278            
279             sub get_select {
280              
281 0     0 0   my $self = shift;
282 0           my ($col1, $col2) = @_;
283              
284 0           my $sql = qq( SELECT DISTINCT $col1, $col2
285             FROM $self->{editor}->{table}
286             );
287              
288 0 0         return $sql unless $self->{step};
289              
290 0           my (@values, $i);
291            
292 0           for my $step(0 .. $self->{step}-1){
293              
294 0 0         $sql .= ' WHERE ' unless $i++;
295 0           $sql .= ($self->parse_params($step))[0] ." = ?";
296 0 0         $sql .= ' AND ' unless $step >= $self->{step}-1;
297              
298 0           push @values,
299             $self->{editor}->{query}->param(($self->parse_params($step))[0]);
300             }
301              
302 0           $sql .= " ORDER BY $col2";
303              
304             # the sql is the first element
305             # the rest of the array is
306             # filled with placeholder vals
307              
308 0           unshift @values, $sql;
309 0           return @values;
310              
311             }
312              
313              
314              
315             # populate search choices
316              
317             sub populate_search {
318              
319 0     0 0   my $self = shift;
320 0           my ($sql, @params) = @_;
321 0           my (@tmpl_loop, @headers, $db_return);
322            
323 0 0         eval {
324 0           $db_return = $self->{editor}->{dbh}->selectall_arrayref($sql,undef,@params);
325 0           1 } or $self->{editor}->_err_msg($@, $sql);
326              
327             # is this the last step?
328 0 0         my $last_step = (($self->{step}+1) >= scalar(@{$self->{params}})) ? 1 : 0;
  0            
329              
330 0 0         my $rm = 'display' if $last_step;
331              
332             # is it the first?
333 0 0         my $cancel = ($self->{step} > 0) ? 1 : 0;
334              
335              
336              
337             # workaround for servers that lack
338             # subqueries ( e.g mysql < 4.1 )
339              
340 0 0         if ($self->{params}->[$self->{step}]->{sql}){
341 0           $db_return = $self->constrain_results($db_return);
342             };
343              
344              
345 0           for my $row_ref(@$db_return){
346 0           my %row = (
347             VALUE => $row_ref->[0],
348             LABEL => $row_ref->[1],
349             RADIO_NAME => ($self->parse_params($self->{step}))[0],
350             );
351              
352             # if final screen, list any
353             # additional columns specified
354            
355 0 0         if ($last_step){
356 0           my @td_loop;
357            
358 0           for my $col_hash(@{$self->{td_cols}}){
  0            
359 0           my $sql = qq( SELECT $col_hash->{column}
360             FROM $self->{editor}->{table}
361             WHERE $self->{editor}->{pk} = ?
362             );
363              
364 0           my $ar;
365 0 0         eval{
366 0           $ar = $self->{editor}->{dbh}->selectrow_arrayref(
367             $sql, undef, $row_ref->[0]
368 0           ); 1
369             } or $self->{editor}->_err_msg($@, $sql);
370            
371 0 0         $ar->[0] = $col_hash->{callback}->($ar->[0])
372             if $col_hash->{callback};
373            
374 0           my %td = (
375             VALUE => $ar->[0]
376             );
377 0           push(@td_loop, \%td);
378             }
379 0           $row{TDS} = \@td_loop;
380             }
381            
382 0           push(@tmpl_loop, \%row);
383             }
384              
385             # if final screen, list any
386             # additional headers specified
387            
388 0 0         if ($last_step){
389 0           for my $col_hash(@{$self->{td_cols}}){
  0            
390              
391 0           my $label = $col_hash->{label};
392            
393 0   0       $label ||= join(' ', map {ucfirst($_)}
  0            
394             split(/_/, $col_hash->{column}));
395            
396 0           my %row = (
397             HEADER => $label
398             );
399 0           push(@headers, \%row);
400             }
401             }
402              
403             # keep track of old choices
404 0           my @prev_vals;
405 0           for my $step(0 .. $self->{step}-1){
406 0           my %row;
407 0           $row{LABEL} = ($self->parse_params($step))[0];
408 0           $row{VALUE} = $self->{editor}->{query}->param(($self->parse_params($step))[0]);
409 0           push @prev_vals, \%row;
410             }
411              
412              
413              
414              
415 0           $self->{template}->param( SEARCH_LOOP => \@tmpl_loop,
416             FORM => 1,
417             RUN_MODE => $rm,
418             CANCEL => $cancel,
419             PREV_VALS => \@prev_vals,
420             HEADERS => \@headers,
421             CUSTOM_CSS => $self->{css},
422             );
423             }
424              
425              
426              
427             # discard extra sql returns
428              
429             sub constrain_results {
430            
431             # this would be much cleaner
432             # but less portable using subqueries
433             # instead of two seperate queries
434              
435 0     0 0   my ($self, $list) = @_;
436              
437             # get a list of all possible
438             # results based on previous selections
439              
440 0           my $sql = qq( SELECT DISTINCT
441             T.$self->{params}->[$self->{step}]->{sql}->[0]
442             FROM $self->{editor}->{table} T
443             );
444              
445 0           my (@values, $i, @results);
446            
447 0           for my $step(0 .. $self->{step}-2){
448              
449 0 0         $sql .= ' WHERE ' unless $i++;
450 0           $sql .= ($self->parse_params($step))[0] ." = ?";
451 0 0         $sql .= ' AND ' unless $step >= $self->{step}-2;
452              
453 0           push @values,
454             $self->{editor}->{query}->param(($self->parse_params($step))[0]);
455             }
456              
457 0           my $selections = $self->{editor}->{dbh}->selectcol_arrayref($sql, undef, @values);
458              
459 0           for my $lr(@$list){
460 0 0         push (@results, $lr) if grep{/^$lr->[0]$/} @$selections;
  0            
461             }
462            
463 0           return \@results;
464             }
465              
466              
467              
468             # create an HTML::Template
469              
470             sub TEMPLATE {
471 0     0 0   qq(
472            
473            
474            
475            
476            
477            
554            
555              
556            
557            
558            
559            
560              
561            
562             class="odd">
563            
564            
565            
566             Select
567            
568              
569            
570            
571            
572            
573            
574            
575            
576            
577            
578            
579            
580              
581            
582             class="odd">
583            
584             value='' checked>
585            
586            
587            
588             class="odd">
589            
590            
591            
592            
593              
594            
595            
596            
597              
598            
599              
600            
601            
602            
603            
604            
605            
606              
607            
608              
609              
610            
611            
612            
613            
614            
615             style="width:80;">
616            
617            
618            
619            
620             onclick='document.location="?rm=display"'
621             style="width:80;">
622            
623              
624            
625            
626             );
627             };
628              
629              
630              
631             1;