File Coverage

blib/lib/SQLite/Work.pm
Criterion Covered Total %
statement 31 800 3.8
branch 4 396 1.0
condition 3 112 2.6
subroutine 7 32 21.8
pod 27 27 100.0
total 72 1367 5.2


'; "; \n"; "; \n"; \n";
line stmt bran cond sub pod time code
1             package SQLite::Work;
2             $SQLite::Work::VERSION = '0.15';
3 2     2   29695 use strict;
  2         4  
  2         60  
4 2     2   6 use warnings;
  2         2  
  2         75  
5              
6             =head1 NAME
7              
8             SQLite::Work - report on and update an SQLite database.
9              
10             =head1 VERSION
11              
12             version 0.15
13              
14             =head1 SYNOPSIS
15              
16             use SQLite::Work;
17              
18             my $rep = SQLite::Work->new(%new_args);
19              
20             if ($rep->do_connect())
21             {
22             if ($simple_report)
23             {
24             $rep->do_report(%report_args);
25             }
26             elsif ($multi_page_report)
27             {
28             $rep->do_multi_page_report(%report_args);
29             }
30             elsif ($split_report)
31             {
32             $rep->do_split_report(%report_args);
33             }
34             $rep->do_disconnect();
35             }
36              
37             =head1 DESCRIPTION
38              
39             SQLite::Work is a perl module for interfacing with an SQLite database.
40             It can be used to:
41              
42             =over
43              
44             =item *
45              
46             generate I HTML (and non-HTML) reports, which
47              
48             =over
49              
50             =item *
51              
52             have nested headers
53              
54             =item *
55              
56             have grouped data which clusters under the headers
57              
58             =item *
59              
60             can be sorted on multiple columns
61              
62             =item *
63              
64             can be customized with templates (both headers and body) which include
65             some simple formatting for column values, for example:
66              
67             simple HTMLize
68             titles (Title,The becomes The Title)
69             names (Nurk,Fred becomes Fred Nurk)
70             month names
71             truncation
72              
73             (see L)
74              
75             =item *
76              
77             one can select the columns and their order even if one isn't using templates
78              
79             =item *
80              
81             default templates can be selected which present the data in tables,
82             in paragraphs (Column:Value) or in lists.
83              
84             =item *
85              
86             can be split into multiple HTML pages, with automatic index-page
87             generation; the split can be on the values of a given column, and/or by
88             number of rows
89              
90             =back
91              
92             =item *
93              
94             use a generic search CGI script ("show.cgi" using SQLite::Work::CGI) which
95              
96             =over
97            
98             =item *
99              
100             can search on all the fields in a table without having to hardcode the
101             column names (it just gets them from the table information)
102              
103             =item *
104              
105             uses most of the power of the report engine to give I search
106             results
107              
108             =back
109              
110             =item *
111              
112             update the database with a CGI script ("edit.cgi" using SQLite::Work::CGI)
113              
114             =item *
115              
116             be able to mail reports to general addresses (such as a mailing list)
117             or to specific addresses (such as sending notifications to individuals
118             whose address is in the database). (using the sqlw_mail script)
119              
120             =back
121              
122             This generates HTML (and non-HTML) reports from an SQLite database,
123             taking care of the query-building and the report formatting. This also
124             has methods for adding and updating the database.
125              
126             The L module has extra methods which deal with CGI using
127             the CGI module; the included "show.cgi" and "edit.cgi" are demonstration
128             CGI scripts which use the SQLite::Work::CGI module. There is also the
129             "show.epl" demonstration Embperl script which has the necessary alterations
130             for using this with Embperl.
131              
132             The L script uses SQLite::Work to generate reports from the
133             command-line.
134              
135             The L script uses SQLite::Work::Mail to email reports.
136              
137             =head2 Limitations
138              
139             This only deals with single tables and views, and simple one-field,
140             two-table joins. More complex joins should be dealt with by making
141             a view.
142              
143             This only deals with one database at a time.
144              
145             =cut
146              
147 2     2   2731 use DBI;
  2         25588  
  2         122  
148 2     2   1025 use POSIX;
  2         9930  
  2         9  
149 2     2   4753 use Text::NeatTemplate;
  2         6098  
  2         13653  
150              
151             =head1 CLASS METHODS
152              
153             =head2 new
154              
155             my $rep = SQLite::Work->new(
156             database=>$database_file,
157             row_ids=>{
158             episodes=>'title_id',
159             },
160             join_cols=>{
161             'episodes+recordings'=>'title_id',
162             }
163             },
164             report_template=>$template,
165             default_format=>{
166             'episodes' => {
167             'title'=>'title',
168             'series_title'=>'title',
169             }
170             },
171             use_package=>[qw(File::Basename MyPackage)],
172             );
173              
174             Make a new report object.
175              
176             This takes the following arguments:
177              
178             =over
179              
180             =item database
181              
182             The name of the SQLite database file. This is required.
183              
184             =item row_ids
185              
186             The default column-name which identifies rows in SQLite is 'rowid', but
187             for tables which have a primary integer key, this doesn't work (even
188             though the documentation says it ought to). Therefore it is necessary
189             to identify, for the given database, which tables need to use a
190             different column-name for this. This gives a hash of table->column
191             names.
192              
193             =item join_cols
194              
195             This covers simple joins of two tables, by providing the name
196             of a commom column on which to join them.
197             This is only used for presenting two tables separately in one
198             report, not for a combined-table report; for that you are
199             required to create a view.
200              
201             Presenting two tables separately in one report is only done when
202             only one row is being shown from the first table; then a second
203             section shows the matching rows from the other table (if a second
204             table has been asked for). This is mainly used for editing
205             purposes (see L).
206              
207             =item report_template
208              
209             Either a string containing a template, or string containing the name of
210             a template file. The template variables are in the following format:
211              
212            
213              
214             The following variables are set for the report:
215              
216             =over
217              
218             =item sqlr_title
219              
220             Title (generally the table name).
221              
222             =item sqlr_contents
223              
224             The report itself.
225              
226             =back
227              
228             =item index_template
229              
230             Similar to the report_template, but this is used for the index-pages
231             in multi-page and split reports. It has the same format, but it
232             can be useful to have them as two separate templates as one may wish
233             to change the way the title is treated for indexes versus actual
234             reports.
235              
236             =item default_format
237              
238             This contains the default format to use for the given columns
239             in the given tables, when generating a row_template if a
240             row_template has not been given.
241             This is useful for things like CGI scripts where it isn't
242             possible to know beforehand what sort of row_template is needed.
243              
244             =item use_package
245              
246             This contains an array of package names of packages to "use".
247             This is mainly so that the {&funcname())} construct of
248             the templates (see L) can call
249             functions within these packages (using their fully-qualified
250             names).
251              
252             =back
253              
254             =cut
255              
256             sub new {
257 1     1 1 317 my $class = shift;
258 1         4 my %parameters = @_;
259 1   33     8 my $self = bless ({%parameters}, ref ($class) || $class);
260 1         6 $self->{message} = '';
261 1 50       3 if (!defined $self->{row_ids})
262             {
263 0         0 $self->{row_ids} = {};
264             }
265              
266 1 50       4 if (!defined $self->{join_cols})
267             {
268 1         3 $self->{join_cols} = {};
269             }
270              
271 1   50     5 $self->{report_template} ||=<
272            
273             <!--sqlr_title-->
274            
275            
276            

277            
278            
279            
280             EOT
281 1   50     4 $self->{index_template} ||=<
282            
283             <!--sqlr_title-->
284            
285            
286            

287            
288            
289            
290             EOT
291              
292             # make the template object
293 1 50       3 if ($parameters{use_package})
294             {
295 0         0 for my $pkg (@{$parameters{use_package}})
  0         0  
296             {
297 0 0       0 eval "use $pkg" if $pkg;
298 0 0       0 die "invalid use $pkg: $@" if $@;
299             }
300             }
301 1         10 $self->{_tobj} = Text::NeatTemplate->new(escape_html=>1);
302              
303 1         11 return ($self);
304             } # new
305              
306             =head1 OBJECT METHODS
307              
308             Methods in the SQLite::Work object interface
309              
310             =head2 do_connect
311              
312             $rep->do_connect();
313              
314             Connect to the database.
315              
316             =cut
317             sub do_connect {
318 1     1 1 184 my $self = shift;
319              
320 1         2 my $database = $self->{database};
321 1 50       2 if ($database)
322             {
323 1         8 my $dbh = DBI->connect("dbi:SQLite:dbname=$database", "", "");
324 0 0         if (!$dbh)
325             {
326 0           $self->print_message("Can't connect to $database: $DBI::errstr");
327 0           return 0;
328             }
329 0           $self->{dbh} = $dbh;
330             }
331             else
332             {
333 0           $self->print_message("No Database given.");
334 0           return 0;
335             }
336             } # do_connect
337              
338             =head2 do_disconnect
339              
340             $rep->do_disconnect();
341              
342             Disconnect from the database.
343              
344             =cut
345             sub do_disconnect {
346 0     0 1   my $self = shift;
347              
348 0           $self->{dbh}->disconnect();
349             } # do_disconnect
350              
351             =head2 do_report
352              
353             $rep->do_report(
354             table=>$table,
355             table2=>$table2,
356             where=>\%where,
357             not_where=>\%not_where,
358             sort_by=>\@sort_by,
359             show=>\@show,
360             distinct=>0,
361             headers=>\@headers,
362             header_start=>1,
363             groups=>\@groups,
364             limit=>$limit,
365             page=>$page,
366             layout=>'table',
367             row_template=>$row_template,
368             outfile=>$outfile,
369             report_style=>'full',
370             table_border=>1,
371             truncate_colnames=>0,
372             title=>'',
373             );
374              
375             Select data from a table in the database, and make a HTML
376             report.
377              
378             Arguments are as follows (in alphabetical order):
379              
380             =over
381              
382             =item distinct
383              
384             If columns are given to show (see L), then this will
385             ensure that rows with exactly the same values will not be
386             repeated.
387              
388             =item groups
389              
390             An array of group templates (or filenames of files containing
391             group templates). A group template is a template for values
392             which are "grouped" under a corresponding header. The first
393             group in the array is placed just after the first header in
394             the report, and so on.
395              
396             See L for more information.
397              
398             =item headers
399              
400             An array of header templates (or filenames of files containing header
401             templates). A header template lays out what values should be put
402             into headers rather than the body of the report. The first header
403             template is given a H1 header, the second a H2 header, and so on.
404             Headers are shown only when the value(s) they depend on change,
405             but they get their values from each row in the report. Therefore
406             the columns used in the headers should match the columns used in the
407             L array.
408              
409             The column names are the variable names in this template. This has
410             a different format to the L; it is more sophisticated.
411              
412             The format is as follows:
413              
414             =over
415              
416             =item {$colname}
417              
418             A variable; will display the value of the column, or nothing if
419             that value is empty.
420              
421             =item {?colname stuff [$colname] more stuff}
422              
423             A conditional. If the value of 'colname' is not empty, this will
424             display "stuff value-of-column more stuff"; otherwise it displays
425             nothing.
426              
427             {?col1 stuff [$col1] thing [$col2]}
428              
429             This would use both the values of col1 and col2 if col1 is not
430             empty.
431              
432             =item {?colname stuff [$colname] more stuff!!other stuff}
433              
434             A conditional with "else". If the value of 'colname' is not empty, this
435             will display "stuff value-of-column more stuff"; otherwise it displays
436             "other stuff".
437              
438             This version can likewise use multiple columns in its display parts.
439              
440             {?col1 stuff [$col1] thing [$col2]!![$col3]}
441              
442             =back
443              
444             The same format is used for L and L.
445              
446             =item header_start
447              
448             At what level the headers should start. Default is 1 (H1).
449              
450             =item layout
451              
452             The layout of the report. This determines both how rows are grouped,
453             and what is in the generated L if no row_template is
454             given.
455              
456             =over
457              
458             =item table
459              
460             The report is a (group of) tables, each row of the report is a row in
461             the table; a new table occurs after the heading(s).
462              
463             =item para
464              
465             The report is in paragraphs, each row of the report is one paragraph.
466              
467             =item list
468              
469             The report is a (group of) lists, each row of the report is an item in
470             the list; a new list occurs after the heading(s).
471              
472             =item fieldval
473              
474             The rows are not HTML-formatted. The generated row_template is made up
475             of Field:Value pairs, one on each line.
476              
477             =item none
478              
479             The rows are not HTML-formatted. The generated row_template is made up
480             of values, one on each line.
481              
482             =back
483              
484             =item limit
485              
486             The maximum number of rows to display per page. If this is zero,
487             then all rows are displayed in one page.
488              
489             =item not_where
490              
491             A hash containing the column names where the selection criteria
492             in L should be negated.
493              
494             =item outfile
495              
496             The name of the output file. If the name is '-' then the output
497             goes to STDOUT.
498              
499             =item page
500              
501             Select which page to generate, if limit is not zero.
502              
503             =item report_style
504              
505             The style of the report, especially as regards table layout.
506              
507             =over
508              
509             =item full
510              
511             =item medium
512              
513             =item compact
514              
515             =item bare
516              
517             =back
518              
519             =item row_template
520              
521             The template for each row. This uses the same format as for L.
522             If none is given, then a default row_template will be generated,
523             depending on what L and which columns are going to be shown
524             (see L).
525              
526             Therefore it is important that if one provides a row_template, that
527             it matches the current layout.
528              
529             Also note that if a column is given in a header, it will not be
530             displayed in a row, even if it is put into the row_template.
531              
532             =item show
533              
534             An array of columns to select; also the order in which they should
535             be shown when a L has not been given.
536              
537             =item sort_by
538              
539             An array of column names by which the result should be sorted.
540             If the column name is prefixed with a "-", the sort order should
541             be reversed for that column.
542              
543             =item table
544              
545             The table to report on. (required)
546              
547             =item table2
548              
549             A second table to report on. If this is given, and L
550             have been defined, and the result of the query on the first table
551             returns only one row (either because there's only one row, or because
552             L was set to 1), then a second, simpler, sub-report will
553             be done on this table, displaying all the rows which match
554             the join-value in the first table.
555              
556             This is only really useful when doing editing with a CGI script.
557              
558             =item table_border
559              
560             For fine-tuning the L; if the L is 'table',
561             then this overrides the default border-size of the table.
562              
563             =item table_header
564              
565             When the report layout is 'table' and the report_style is not 'bare',
566             then this argument can be used to customize the table-header
567             of the report table. This must either contain the contents
568             of the table-header, or the name of a file which contains
569             the contents of the table-header.
570              
571             If this argument is not given, the table-header will be constructed
572             from the column names of the columns to be shown.
573              
574             =item title
575              
576             The title of the report; if this is empty, a title will be generated.
577              
578             =item truncate_colnames
579              
580             For fine-tuning the L; this affects the length of
581             column names given in layouts which use them, that is, 'table'
582             (for all styles except 'bare') and 'para'. If the value is zero,
583             the column names are not truncated at all; otherwise they are
584             truncated to that number of characters.
585              
586             =item where
587              
588             A hash containing selection criteria. The keys are the column names
589             and the values are strings suitable for using in a GLOB condition;
590             that is, '*' is a multi-character wildcard, and '?' is a
591             single-character wildcard. All the conditions will be ANDed together.
592              
593             Yes, this is limited and doesn't use the full power of SQL, but it's
594             useful enough for most purposes.
595              
596             =back
597              
598             =cut
599             sub do_report {
600 0     0 1   my $self = shift;
601 0           my %args = (
602             table=>undef,
603             command=>'Select',
604             limit=>0,
605             page=>1,
606             table2=>'',
607             headers=>[],
608             header_start=>1,
609             groups=>[],
610             sort_by=>undef,
611             not_where=>{},
612             where=>{},
613             show=>[],
614             layout=>'table',
615             row_template=>'',
616             outfile=>'',
617             report_style=>'full',
618             title=>'',
619             prev_file=>'',
620             next_file=>'',
621             @_
622             );
623 0           my $table = $args{table};
624 0           my $command = $args{command};
625 0           my @columns = (@{$args{show}}
  0            
626 0 0         ? @{$args{show}}
627             : $self->get_colnames($table));
628              
629 0           my $total = $self->get_total_matching(%args);
630              
631 0           my ($sth1, $sth2) = $self->make_selections(%args,
632             total=>$total);
633 0           $self->print_select($sth1,
634             $sth2,
635             %args,
636             message=>$self->{message},
637             command=>$command,
638             total=>$total,
639             columns=>\@columns,
640             );
641             } # do_report
642              
643             =head2 do_multi_page_report
644              
645             $rep->do_multi_page_report(
646             table=>$table,
647             table2=>$table2,
648             where=>\%where,
649             not_where=>\%not_where,
650             sort_by=>\@sort_by,
651             show=>\@show,
652             headers=>\@headers,
653             groups=>\@groups,
654             limit=>$limit,
655             page=>$page,
656             layout=>'table',
657             row_template=>$row_template,
658             prev_next_template=>$prev_next_template,
659             multi_page_template=>$multi_page_template,
660             outfile=>$outfile,
661             table_border=>1,
662             table_class=>'plain',
663             truncate_colnames=>0,
664             report_style=>'full',
665             link_suffix=>'.html',
666             );
667              
668             Select data from a table in the database, and make a HTML
669             file for EVERY page in the report.
670              
671             If the limit is zero, or the number of rows is less than the limit, or
672             the outfile is destined for STDOUT, then calls do_report to do a
673             single-page report.
674              
675             If no rows match the criteria, does nothing and returns false.
676              
677             Otherwise, it uses the 'outfile' name as a base upon which to build the
678             file-names for all pages in the report (basically appending the
679             page-number to the name), and generates a report file for each of them,
680             and an index-page file which is called the 'outfile' value.
681              
682             The 'link_suffix' argument, if given, overrides the suffix given
683             in links to the other pages in this multi-page report; this is useful
684             if you're post-processing the files (and thus changing their extensions)
685             or are using something like Apache MultiViews to eliminate the need for
686             extensions in links.
687              
688             See L for information about the rest of the arguments.
689              
690             =cut
691             sub do_multi_page_report {
692 0     0 1   my $self = shift;
693 0           my %args = (
694             table=>undef,
695             command=>'Select',
696             limit=>0,
697             page=>1,
698             table2=>'',
699             headers=>[],
700             header_start=>1,
701             groups=>[],
702             sort_by=>undef,
703             not_where=>{},
704             where=>{},
705             show=>[],
706             layout=>'table',
707             row_template=>'',
708             prev_next_template=>'',
709             multi_page_template=>'',
710             outfile=>'',
711             report_style=>'full',
712             title=>'',
713             verbose=>0,
714             prev_file=>'',
715             prev_label=>'',
716             next_file=>'',
717             next_label=>'',
718             link_suffix=>undef,
719             @_
720             );
721            
722             # check if we just want a single page
723 0 0 0       if ($args{limit} == 0
      0        
724             or $args{outfile} eq ''
725             or $args{outfile} eq '-')
726             {
727 0           return $self->do_report(%args);
728             }
729              
730 0           my $total = $self->get_total_matching(%args);
731 0           my $num_pages = ceil($total / $args{limit});
732             # if there's only one page, do a single-page report also
733 0 0         if ($num_pages == 1)
734             {
735 0           return $self->do_report(%args, limit=>0);
736             }
737 0 0         if ($num_pages == 0)
738             {
739 0           return 0;
740             }
741 0 0         print STDERR "About to generate $num_pages PAGES\n" if $args{verbose};
742             # split the outfile into prefix and suffix
743 0           $args{outfile} =~ m#(.*)(\.\w+)$#;
744 0           my $outfile_prefix = $1;
745 0 0         my $outfile_suffix = ($2 ? $2 : '.html');
746 0 0         my $link_suffix = (defined $args{link_suffix} ? $args{link_suffix}
747             : $outfile_suffix);
748             # width of the page-id
749 0 0         my $digits = ($num_pages < 10 ? 1
    0          
750             : ($num_pages < 100 ? 2 : 3)
751             );
752              
753             # stuff for the index page
754 0 0         my $title_main = ($args{title} ? $args{title} : $args{table});
755             # fix up random ampersands
756 0 0         if ($title_main =~ / & /)
757             {
758 0           $title_main =~ s/ & / & /g;
759             }
760 0 0         my $multi_page_template = ($args{multi_page_template}
761             ? $args{multi_page_template}
762             : '
  • {$title_main} ({$page})
  • 763             '
    764             );
    765 0           my $ind_contents;
    766 0           $ind_contents = "
      ";
    767              
    768             # make a report for each page
    769 0           for (my $page = 1; $page <= $num_pages; $page++)
    770             {
    771 0           my $outfile = sprintf("%s_%0*d%s",
    772             $outfile_prefix, $digits, $page, $outfile_suffix);
    773 0           my $outfile_link = sprintf("%s_%0*d%s",
    774             $outfile_prefix, $digits, $page, $link_suffix);
    775 0 0         my $prevfile = ($page > 1
    776             ? sprintf("%s_%0*d%s",
    777             $outfile_prefix, $digits,
    778             $page - 1, $link_suffix)
    779             : sprintf("%s%s", $outfile_prefix, $link_suffix)
    780             );
    781 0 0         my $prevlabel = ($page > 1
    782             ? sprintf("%s (%d)", $title_main, $page - 1)
    783             : sprintf("%s Index", $title_main));
    784 0 0         my $nextfile = ($page < $num_pages
    785             ? sprintf("%s_%0*d%s",
    786             $outfile_prefix, $digits,
    787             $page + 1, $link_suffix)
    788             : $args{next_file});
    789 0 0         my $nextlabel = ($page < $num_pages
    790             ? sprintf("%s (%d)", $title_main, $page + 1)
    791             : $args{next_label});
    792 0           $self->do_report(%args,
    793             outfile=>$outfile,
    794             prev_file=>$prevfile,
    795             prev_label=>$prevlabel,
    796             next_file=>$nextfile,
    797             next_label=>$nextlabel,
    798             page=>$page);
    799 0 0         print STDERR "$outfile\n" if $args{verbose};
    800 0           my %mp_hash = (
    801             outfile_link=>$outfile_link,
    802             title_main=>$title_main,
    803             page=>$page,
    804             );
    805 0           my $mp_templ = $self->get_template($multi_page_template);
    806 0           my $mp_str = $self->{_tobj}->fill_in(data_hash=>\%mp_hash,
    807             template=>$mp_templ);
    808 0           $ind_contents .= $mp_str;
    809             }
    810 0           $ind_contents .= "\n";
    811              
    812             # append the prev-next links, if any
    813 0 0 0       if ($args{prev_file} or $args{next_file})
    814             {
    815 0           my $prev_label = $args{prev_label};
    816 0           $prev_label =~ s/ & / & /g;
    817 0           my $next_label = $args{next_label};
    818 0           $next_label =~ s/ & / & /g;
    819 0           my %pn_hash = (
    820             prev_file => $args{prev_file},
    821             prev_label => $prev_label,
    822             next_file => $args{next_file},
    823             next_label => $next_label,
    824             );
    825 0 0         my $pn_template = ($args{prev_next_template}
    826             ? $args{prev_next_template}
    827             : '
    828            

    {?prev_file [$prev_label]}

    829             {?next_file [$next_label]}
    830            

    831             '
    832             );
    833 0           my $pn_templ = $self->get_template($pn_template);
    834 0           my $pn_str = $self->{_tobj}->fill_in(data_hash=>\%pn_hash,
    835             template=>$pn_templ);
    836 0           $ind_contents .= $pn_str;
    837             }
    838              
    839             # and make the index page
    840 0           my $out = $self->get_template($self->{index_template});
    841 0           $self->{index_template} = $out;
    842 0           $out =~ s//$title_main/g;
    843 0           $out =~ s//$ind_contents/g;
    844 0           my $fh;
    845 0 0         open($fh, ">", $args{outfile})
    846             or die "Could not open $args{outfile} for writing";
    847 0           print $fh $out;
    848 0           close($fh);
    849              
    850 0           return 1;
    851             } # do_multi_page_report
    852              
    853             =head2 do_split_report
    854              
    855             $rep->do_split_report(
    856             table=>$table,
    857             split_col=>$colname,
    858             split_alpha=>$n,
    859             command=>'Select',
    860             table2=>$table2,
    861             where=>\%where,
    862             not_where=>\%not_where,
    863             sort_by=>\@sort_by,
    864             show=>\@show,
    865             headers=>\@headers,
    866             header_start=>1,
    867             groups=>\@groups,
    868             limit=>$limit,
    869             page=>$page,
    870             layout=>'table',
    871             row_template=>$row_template,
    872             outfile=>$outfile,
    873             table_border=>1,
    874             table_class=>'plain',
    875             truncate_colnames=>0,
    876             report_style=>'full',
    877             link_suffix=>'.html',
    878             );
    879              
    880             Build up a multi-file report, splitting it into different pages for each
    881             distinct value of the 'split_col' column. (If the outfile is destined
    882             for STDOUT, then this will call do_report intead).
    883              
    884             The filenames generated will use 'outfile' as a prefix, and
    885             the column name and values as the rest; this calls in turn
    886             L to break those into multiple pages
    887             if need be. An index-page is also generated, which will be
    888             called I + I + .html
    889              
    890             If 'split_alpha' is also given and is not zero, then instead of
    891             splitting on each distinct value in the 'split_col' column, the
    892             split is done by the truncated values of that column; if 'split_alpha'
    893             is 1, then the split is by the first letter, if it is 2, by the first
    894             two letters, and so on.
    895              
    896             The 'link_suffix' argument, if given, overrides the suffix given
    897             in links to the other pages in this multi-page report; this is useful
    898             if you're post-processing the files (and thus changing their extensions)
    899             or are using something like Apache MultiViews to eliminate the need for
    900             extensions in links.
    901              
    902             See L for information about the rest of the arguments.
    903              
    904             =cut
    905             sub do_split_report {
    906 0     0 1   my $self = shift;
    907 0           my %args = (
    908             table=>undef,
    909             split_col=>'',
    910             split_alpha=>0,
    911             filename_format=>'namedalpha',
    912             command=>'Select',
    913             limit=>0,
    914             page=>1,
    915             table2=>'',
    916             headers=>[],
    917             header_start=>1,
    918             groups=>[],
    919             sort_by=>undef,
    920             not_where=>{},
    921             where=>{},
    922             show=>[],
    923             layout=>'table',
    924             row_template=>'',
    925             split_ind_template=>'',
    926             outfile=>'',
    927             report_style=>'full',
    928             title=>'',
    929             verbose=>0,
    930             debug=>0,
    931             link_suffix=>undef,
    932             @_
    933             );
    934            
    935             # check for STDOUT destination
    936 0 0         if ($args{outfile} eq '-')
    937             {
    938 0           return $self->do_report(%args);
    939             }
    940 0           my $split_col = $args{split_col};
    941 0           my $split_alpha = $args{split_alpha};
    942              
    943             # split the outfile into prefix and suffix
    944 0           my $outfile_prefix = '';
    945 0           my $outfile_suffix = '.html';
    946 0 0         if ($args{outfile})
    947             {
    948 0           $args{outfile} =~ m/(.*)(\.\w+)$/;
    949 0           $outfile_prefix = $1;
    950 0 0         $outfile_suffix = ($2 ? $2 : '.html');
    951             }
    952 0 0         my $link_suffix = (defined $args{link_suffix} ? $args{link_suffix}
    953             : $outfile_suffix);
    954              
    955 0           my $total = $self->get_total_matching(%args);
    956 0           my @split_vals = $self->get_distinct_col(%args,
    957             colname=>$split_col);
    958 0 0         if ($split_alpha)
    959             {
    960 0           my %split_avals = ();
    961 0           foreach my $val (@split_vals)
    962             {
    963 0 0 0       my $a1 = substr(($val||''), 0, ($split_alpha ? $split_alpha : 1));
    964 0           $a1 = uc($a1);
    965 0           $split_avals{$a1} = 1;
    966             }
    967 0           @split_vals = sort keys %split_avals;
    968             }
    969              
    970 0 0 0       my $two_level_ind = (($split_alpha or @split_vals < 15) ? 0 : 1);
    971              
    972             # stuff for the index page
    973 0 0         my $title_main = ($args{title} ? $args{title} : "$args{table} $split_col");
    974 0           my %page_links = ();
    975              
    976 0 0         my $si_template = ($args{split_ind_template}
    977             ? $args{split_ind_template}
    978             : '{$label}'
    979             );
    980 0           my $si_templ = $self->get_template($si_template);
    981              
    982             # make a page for each split-value
    983 0           my %where = %{$args{where}};
      0            
    984 0           for (my $i = 0; $i < @split_vals; $i++)
    985             {
    986 0           my $val = $split_vals[$i];
    987 0 0         $val = '' if !$val;
    988 0           my $niceval = $val;
    989 0 0         $niceval = $self->{_tobj}->convert_value(value=>$val,
    990             format=>$self->{default_format}->
    991             {$args{table}}->{$split_col},
    992             name=>$split_col)
    993             if ($self->{default_format}->{$args{table}}->{$split_col});
    994              
    995 0           my $valbase = $self->{_tobj}->convert_value(value=>$niceval,
    996             format=>$args{filename_format}, name=>$split_col);
    997 0 0         warn "val=$val, niceval=$niceval, valbase=$valbase\n" if $args{debug};
    998 0           my $outfile = sprintf("%s%s%s",
    999             $outfile_prefix, $valbase, $outfile_suffix);
    1000 0           my $outfile_link = sprintf("%s%s%s",
    1001             $outfile_prefix, $valbase, $link_suffix);
    1002              
    1003             # previous values
    1004 0           my $prev_val = '';
    1005 0           my $prev_niceval = '';
    1006 0           my $prev_file = '';
    1007 0 0         if ($i > 0)
    1008             {
    1009 0           $prev_val = $split_vals[$i-1];
    1010 0           $prev_niceval = $prev_val;
    1011 0 0         $prev_niceval = $self->{_tobj}->convert_value(value=>$prev_val,
    1012             format=>$self->{default_format}->
    1013             {$args{table}}->{$split_col},
    1014             name=>$split_col)
    1015             if ($self->{default_format}->{$args{table}}->{$split_col});
    1016 0           my $prev_valbase = $self->{_tobj}->convert_value(value=>$prev_niceval,
    1017             format=>$args{filename_format},
    1018             name=>$split_col);
    1019 0           $prev_file = sprintf("%s%s%s",
    1020             $outfile_prefix,
    1021             $prev_valbase, $link_suffix);
    1022             }
    1023              
    1024             # next values
    1025 0           my $next_val = '';
    1026 0           my $next_niceval = '';
    1027 0           my $next_file = '';
    1028 0 0         if ($i < (@split_vals - 1))
    1029             {
    1030 0           $next_val = $split_vals[$i+1];
    1031 0           $next_niceval = $next_val;
    1032 0 0         $next_niceval = $self->{_tobj}->convert_value(value=>$next_val,
    1033             format=>$self->{default_format}->
    1034             {$args{table}}->{$split_col},
    1035             name=>$split_col)
    1036             if ($self->{default_format}->{$args{table}}->{$split_col});
    1037 0           my $next_valbase = $self->{_tobj}->convert_value(value=>$next_niceval,
    1038             format=>$args{filename_format},
    1039             name=>$split_col);
    1040 0           $next_file = sprintf("%s%s%s",
    1041             $outfile_prefix,
    1042             $next_valbase,
    1043             $link_suffix);
    1044             }
    1045              
    1046 0 0 0       if ($val and $args{split_alpha})
    1047             {
    1048             # starts with the value
    1049 0           $where{$split_col} = $val . '*';
    1050             }
    1051             else
    1052             {
    1053 0           $where{$split_col} = $val;
    1054             }
    1055 0           my $prev_label = "< $prev_niceval";
    1056 0           $prev_label =~ s/ & / & /g;
    1057 0           my $next_label = "$next_niceval ->";
    1058 0           $next_label =~ s/ & / & /g;
    1059 0           my $mtitle = "$split_col: $niceval";
    1060 0 0         if ($args{split_titlefmt})
    1061             {
    1062 0           $mtitle = $args{split_titlefmt};
    1063 0           $mtitle =~ s/SPLIT_COL/$split_col/g;
    1064 0           $mtitle =~ s/VALUE/$niceval/g;
    1065             }
    1066 0 0         if ($self->do_multi_page_report(%args,
    1067             outfile=>$outfile,
    1068             prev_file=>$prev_file,
    1069             prev_label=>$prev_label,
    1070             next_file=>$next_file,
    1071             next_label=>$next_label,
    1072             where=>\%where,
    1073             title=>$mtitle))
    1074             {
    1075 0 0         print STDERR "$outfile\n" if $args{verbose};
    1076 0 0         if ($val)
    1077             {
    1078 0           my $label = $val;
    1079 0 0         if ($niceval ne $val)
    1080             {
    1081 0           $label = $niceval;
    1082             }
    1083 0 0         if ($label =~ / & /)
    1084             {
    1085             # filter out some HTML stuff
    1086 0           $label =~ s/ & / & /g;
    1087             }
    1088 0           my %si_hash = (
    1089             link=>$outfile_link,
    1090             label=>$label,
    1091             );
    1092 0           $page_links{$val} =
    1093             $self->{_tobj}->fill_in(data_hash=>\%si_hash,
    1094             template=>$si_templ);
    1095             }
    1096             else
    1097             {
    1098 0           my %si_hash = (
    1099             link=>$outfile_link,
    1100             label=>"$split_col (none)",
    1101             );
    1102 0           $page_links{''} =
    1103             $self->{_tobj}->fill_in(data_hash=>\%si_hash,
    1104             template=>$si_templ);
    1105             }
    1106             }
    1107             }
    1108              
    1109             #
    1110             # build the index page
    1111             #
    1112 0           my $ind_contents = '';
    1113              
    1114 0 0         if ($two_level_ind)
        0          
    1115             {
    1116             # find out all the alphas in the links
    1117 0           my %page_alphas = ();
    1118 0           foreach my $val (keys %page_links)
    1119             {
    1120 0 0 0       my $a1 = substr(($val||''), 0, ($split_alpha ? $split_alpha : 1));
    1121 0           $a1 = uc($a1);
    1122 0           $page_alphas{$a1} = 1;
    1123             }
    1124 0           $ind_contents .= "

    ";

    1125 0           my @links = ();
    1126 0           foreach my $a (sort keys %page_alphas)
    1127             {
    1128 0 0         push @links, "$a" if $a;
    1129             }
    1130 0           $ind_contents .= join(' | ', @links);
    1131 0           $ind_contents .= "

    \n
    \n";
    1132             }
    1133             elsif ($split_alpha)
    1134             {
    1135 0           $ind_contents .= "

    ";

    1136             }
    1137             else
    1138             {
    1139 0           $ind_contents .= "
      ";
    1140             }
    1141 0           my $prev_a = undef;
    1142 0           foreach my $indval (sort keys %page_links)
    1143             {
    1144 0           my $link = $page_links{$indval};
    1145 0           my $a1 = substr($indval, 0, 1);
    1146 0 0 0       if ($two_level_ind and (!defined $prev_a or $a1 ne $prev_a))
          0        
    1147             {
    1148 0 0         if (defined $prev_a)
    1149             {
    1150 0           $ind_contents .= "\n";
    1151             }
    1152 0 0         $ind_contents .= "

    $a1

    \n" if $a1;
    1153 0           $ind_contents .= "
      ";
    1154 0           $prev_a = $a1;
    1155             }
    1156 0 0         $ind_contents .= ($split_alpha ? ' ' : '
  • ');
  • 1157 0           $ind_contents .= $link;
    1158 0 0         $ind_contents .= ($split_alpha ? ' ' : "\n");
    1159             }
    1160 0 0         $ind_contents .= ($split_alpha ? "

    \n" : "\n");
    1161              
    1162             # and make the index page
    1163 0           my $out = $self->get_template($self->{index_template});
    1164 0           $self->{index_template} = $out;
    1165 0           $out =~ s//$title_main/g;
    1166 0           $out =~ s//$ind_contents/g;
    1167 0           my $index_file = sprintf("%s%s%s",
    1168             $outfile_prefix, $split_col, $outfile_suffix);
    1169 0           my $fh;
    1170 0 0         open($fh, ">", $index_file)
    1171             or die "Could not open $index_file for writing";
    1172 0           print $fh $out;
    1173 0           close($fh);
    1174 0 0         print STDERR "$index_file\n" if $args{verbose};
    1175              
    1176             } # do_split_report
    1177              
    1178             =head2 get_total_matching
    1179              
    1180             $rep->get_total_matching(
    1181             table=>$table,
    1182             where=>\%where,
    1183             not_where=>\%not_where,
    1184             );
    1185              
    1186             Get the total number of rows which match the selection
    1187             criteria.
    1188              
    1189             See L for the meaning of the arguments.
    1190              
    1191             =cut
    1192             sub get_total_matching {
    1193 0     0 1   my $self = shift;
    1194 0           my %args = (
    1195             table=>undef,
    1196             not_where=>{},
    1197             where=>{},
    1198             @_
    1199             );
    1200 0           my $table = $args{table};
    1201              
    1202             # build up the query data
    1203 0           my @where = $self->build_where_conditions(%args,
    1204             where=>$args{where}, not_where=>$args{not_where});
    1205            
    1206 0           my $total_query = "SELECT COUNT(*) FROM $table";
    1207 0 0         if (@where)
    1208             {
    1209 0           $total_query .= " WHERE " . join(" AND ", @where);
    1210             }
    1211             # get total of the result as if there was no LIMIT
    1212 0           my $tot_sth = $self->{dbh}->prepare($total_query);
    1213 0 0         if (!$tot_sth)
    1214             {
    1215 0           $self->print_message("Can't prepare query $total_query: $DBI::errstr");
    1216 0           return 0;
    1217             }
    1218 0           my $rv = $tot_sth->execute();
    1219 0 0         if (!$rv)
    1220             {
    1221 0           $self->print_message("Can't execute query $total_query: $DBI::errstr");
    1222 0           return 0;
    1223             }
    1224 0           my $total = 0;
    1225 0           my @row;
    1226 0           while (@row = $tot_sth->fetchrow_array)
    1227             {
    1228 0           $total = $row[0];
    1229             }
    1230 0           return $total;
    1231              
    1232             } # get_total_matching
    1233              
    1234             =head2 update_one_row
    1235              
    1236             if ($rep->update_one_field(
    1237             table=>$table,
    1238             row_id=>$row_id,
    1239             field=>$field,
    1240             update_values=>\%values,
    1241             ))
    1242             {
    1243             ...
    1244             }
    1245              
    1246             Update one row; either a single column, or the whole row.
    1247             Returns 0 if failure, or the constructed update query if
    1248             success (so that one can be informative).
    1249              
    1250             Sets $rep->{message} with a success message if successful.
    1251              
    1252             =cut
    1253             sub update_one_row {
    1254 0     0 1   my $self = shift;
    1255 0           my %args = (
    1256             table=>'',
    1257             command=>'Update',
    1258             row_id=>undef,
    1259             field=>'',
    1260             update_values=>{},
    1261             @_
    1262             );
    1263              
    1264 0           my $table = $args{table};
    1265 0           my $row_id_name = $self->get_id_colname($table);
    1266 0           my $row_id = $args{row_id};
    1267 0 0         if (!$row_id)
    1268             {
    1269 0           $self->print_message("Can't update table $table: row-id $row_id_name is NULL");
    1270 0           return 0;
    1271             }
    1272 0           my $update_field = $args{field};
    1273 0           my %update_values = %{$args{update_values}};
      0            
    1274              
    1275 0           my $update_query = "UPDATE $table SET ";
    1276 0           my @assignments = ();
    1277 0           foreach my $ufield (keys %update_values)
    1278             {
    1279 0 0         if ($update_values{$ufield} eq 'NULL')
        0          
    1280             {
    1281 0           push @assignments, "$ufield = NULL";
    1282             }
    1283             elsif ($self->col_is_int(table=>$table, column=>$ufield))
    1284             {
    1285 0 0         push @assignments, "$ufield = ".
    1286             ($update_values{$ufield} ? $update_values{$ufield} : '0');
    1287             }
    1288             else
    1289             {
    1290 0           push @assignments, "$ufield = ".
    1291             $self->{dbh}->quote($update_values{$ufield});
    1292             }
    1293             }
    1294 0           $update_query .= join(', ', @assignments);
    1295 0           $update_query .= " WHERE $row_id_name = $row_id";
    1296            
    1297             # actual update
    1298 0           my $rv = $self->{dbh}->do($update_query);
    1299 0 0         if (!$rv)
    1300             {
    1301 0           $self->print_message("Can't execute update $update_query: $DBI::errstr");
    1302 0           return 0;
    1303             }
    1304 0           $self->{message} = "SUCCESS: $update_query";
    1305 0           return 1;
    1306              
    1307             } # update_one_row
    1308              
    1309             =head2 add_one_row
    1310              
    1311             if ($rep->add_one_row(
    1312             table=>$table,
    1313             add_values=>\%values)) { ...
    1314             }
    1315              
    1316             Add a row to a table.
    1317              
    1318             Sets $rep->{message} with a success message if successful.
    1319              
    1320             =cut
    1321             sub add_one_row {
    1322 0     0 1   my $self = shift;
    1323 0           my %args = (
    1324             table=>'',
    1325             add_values=>{},
    1326             @_
    1327             );
    1328              
    1329 0           my $table = $args{table};
    1330 0           my %add_vals = %{$args{add_values}};
      0            
    1331 0           my @columns = $self->get_colnames($table, do_rowid=>0);
    1332 0           my $row_id_name = $self->get_id_colname($table);
    1333              
    1334 0           my $iquery = "INSERT INTO $table (";
    1335 0           $iquery .= join(', ', @columns);
    1336 0           $iquery .= ") VALUES (";
    1337 0           my @vals = ();
    1338 0           foreach my $col (@columns)
    1339             {
    1340 0           my $val = $add_vals{$col};
    1341 0 0 0       if (!defined $val or $val eq 'NULL')
        0          
    1342             {
    1343 0           push @vals, 'NULL';
    1344             }
    1345             elsif ($col eq $row_id_name)
    1346             {
    1347             # if we are adding, this value needs to be null
    1348 0           push @vals, 'NULL';
    1349             }
    1350             else
    1351             {
    1352 0 0         if ($self->col_is_int(table=>$table, column=>$col))
    1353             {
    1354 0 0         push @vals, ($val ? $val : '0');
    1355             }
    1356             else
    1357             {
    1358             # correct quotes
    1359 0           push @vals, $self->{dbh}->quote($val);
    1360             }
    1361             }
    1362             }
    1363 0           $iquery .= join(',', @vals);
    1364 0           $iquery .= ")";
    1365            
    1366             # actual update
    1367 0           my $rv = $self->{dbh}->do($iquery);
    1368 0 0         if (!$rv)
    1369             {
    1370 0           $self->print_message("Can't execute insert $iquery: $DBI::errstr");
    1371 0           return 0;
    1372             }
    1373 0           $self->{message} = "SUCCESS: " . $iquery;
    1374 0           return 1;
    1375              
    1376             } # add_one_row
    1377              
    1378             =head2 delete_one_row
    1379              
    1380             if ($rep->delete_one_row(
    1381             table=>$table,
    1382             row_id=>$row_id)) { ...
    1383             }
    1384              
    1385             Delete a single row.
    1386              
    1387             Sets $rep->{message} with a success message if successful.
    1388              
    1389             =cut
    1390             sub delete_one_row {
    1391 0     0 1   my $self = shift;
    1392 0           my %args = (
    1393             table=>'',
    1394             row_id=>undef,
    1395             @_
    1396             );
    1397              
    1398 0           my $table = $args{table};
    1399 0           my $row_id_name = $self->get_id_colname($table);
    1400 0           my $row_id = $args{row_id};
    1401 0 0         if (!$row_id)
    1402             {
    1403 0           $self->print_message("Can't delete from table $table: row-id $row_id_name is NULL");
    1404 0           return 0;
    1405             }
    1406 0           my $dquery = "DELETE FROM $table WHERE $row_id_name = $row_id";
    1407            
    1408             # actual update
    1409 0           my $rv = $self->{dbh}->do($dquery);
    1410 0 0         if (!$rv)
    1411             {
    1412 0           $self->print_message("Can't execute update $dquery: $DBI::errstr");
    1413 0           return 0;
    1414             }
    1415 0           $self->{message} = "SUCCESS: " . $dquery;
    1416 0           return 1;
    1417              
    1418             } # delete_one_row
    1419              
    1420             =head2 do_import_fv
    1421              
    1422             if ($rep->do_import_fv(
    1423             table=>$table,
    1424             datafile=>$filename,
    1425             row_delim=>"=")) { ...
    1426             }
    1427              
    1428             Import a field:value file into the given table.
    1429             Field names are taken from the table; rows not starting
    1430             with a field name "Field:" are taken to be a continuation
    1431             of the previous field value.
    1432              
    1433             Rows are delimited by the given row_delim argument on a line
    1434             by itself.
    1435              
    1436             Returns the number of records imported.
    1437              
    1438             =cut
    1439             sub do_import_fv {
    1440 0     0 1   my $self = shift;
    1441 0           my %args = (
    1442             table=>'',
    1443             datafile=>'',
    1444             row_delim=>"=",
    1445             @_
    1446             );
    1447              
    1448 0           my $table = $args{table};
    1449 0           my $row_delim = $args{row_delim};
    1450 0           my $datafile = $args{datafile};
    1451              
    1452 0 0         if (!-r $datafile)
    1453             {
    1454 0           warn "cannot read $datafile";
    1455 0           return 0;
    1456             }
    1457 0           my $fh;
    1458 0 0         open($fh, $datafile)
    1459             or die "cannot open $datafile";
    1460              
    1461 0           my $count = 0;
    1462             # get the legal column names
    1463 0           my @columns = $self->get_colnames($table,
    1464             do_rowid=>0);
    1465 0           my %legal_cols = ();
    1466 0           foreach my $col (@columns)
    1467             {
    1468 0           $legal_cols{$col} = 1;
    1469             }
    1470              
    1471 0           my %vals = ();
    1472 0           my $cur_field;
    1473 0           while (<$fh>)
    1474             {
    1475 0           chomp;
    1476 0 0         if (/^$row_delim$/)
        0          
    1477             {
    1478 0 0         if (!$self->add_one_row(table=>$table,
    1479             add_values=>\%vals))
    1480             {
    1481 0           warn "failed to add row -- aborting\n";
    1482 0           return 0;
    1483             }
    1484 0           $count++;
    1485 0           %vals = ();
    1486             }
    1487             elsif (/^(\w+):(.*)/)
    1488             {
    1489 0           my $fn = $1;
    1490 0           my $v1 = $2;
    1491 0 0         if ($legal_cols{$fn})
    1492             {
    1493             # is a new value
    1494 0           $cur_field = $fn;
    1495 0           $vals{$cur_field} = $v1;
    1496             }
    1497             else
    1498             {
    1499             # is continuation
    1500 0           $vals{$cur_field} .= "\n$_";
    1501             }
    1502             }
    1503             else
    1504             {
    1505 0           $vals{$cur_field} .= "\n$_";
    1506             }
    1507             }
    1508 0           return $count;
    1509              
    1510             } # do_import_fv
    1511              
    1512             =head1 Helper Methods
    1513              
    1514             Lower-level methods, generally just called from other methods,
    1515             but possibly suitable for other things.
    1516              
    1517             =head2 print_message
    1518              
    1519             Print an (error) message to the user.
    1520              
    1521             $self->print_message($message); # error message
    1522              
    1523             $self->print_message($message, 0); # non-error message
    1524              
    1525             (here so that it can be overridden, say, for a CGI script)
    1526              
    1527             =cut
    1528             sub print_message {
    1529 0     0 1   my $self = shift;
    1530 0           my $message = shift;
    1531 0 0         my $is_error = (@_ ? shift : 1); # assume error message
    1532              
    1533 0 0         if ($is_error)
    1534             {
    1535 0           warn $message, "\n";
    1536             }
    1537             else
    1538             {
    1539 0           print $message, "\n";
    1540             }
    1541             } # print_message
    1542              
    1543             =head2 make_selections
    1544              
    1545             my ($sth1, $sth2) = $rep->make_selections(%args);
    1546              
    1547             Make the selection(s) for the matching table(s).
    1548              
    1549             =cut
    1550             sub make_selections {
    1551 0     0 1   my $self = shift;
    1552 0           my %args = (
    1553             table=>undef,
    1554             command=>'Select',
    1555             limit=>0,
    1556             page=>1,
    1557             table2=>'',
    1558             sort_by=>undef,
    1559             not_where=>{},
    1560             where=>{},
    1561             show=>[],
    1562             distinct=>0,
    1563             @_
    1564             );
    1565 0           my $table = $args{table};
    1566 0           my $command = $args{command};
    1567              
    1568 0           my @sort_by = (!defined $args{sort_by}
    1569             ? ()
    1570             : (!ref $args{sort_by}
    1571             ? split(' ', $args{sort_by})
    1572 0 0         : @{$args{sort_by}}));
        0          
    1573 0           my @columns = (@{$args{show}}
      0            
    1574 0 0         ? @{$args{show}}
    1575             : $self->get_colnames($table));
    1576 0           my $limit = $args{limit};
    1577 0           my $page = $args{page};
    1578 0           my $table2 = $args{table2};
    1579              
    1580 0           my $row_id_name = $self->get_id_colname($table);
    1581 0           my $offset = $limit * ($page - 1);
    1582 0 0         $offset = 0 if $offset < 0;
    1583              
    1584             # build up the query data
    1585 0           my @where = $self->build_where_conditions(%args,
    1586             where=>$args{where}, not_where=>$args{not_where});
    1587            
    1588 0           my $jquery = '';
    1589 0           my $join_col = $self->get_join_colname($table, $table2);
    1590 0           $jquery = "SELECT DISTINCT $join_col FROM $table";
    1591 0           my $query = "SELECT ";
    1592 0 0         if (@columns)
    1593             {
    1594 0 0         $query .= "DISTINCT " if $args{distinct};
    1595 0           $query .= join(", ", @columns);
    1596             }
    1597             else
    1598             {
    1599 0           $query .= "*";
    1600             }
    1601 0           $query .= " FROM $table";
    1602 0 0         if (@where)
    1603             {
    1604 0           $query .= " WHERE " . join(" AND ", @where);
    1605 0           $jquery .= " WHERE " . join(" AND ", @where);
    1606             }
    1607 0 0         if (@sort_by)
    1608             {
    1609 0           my @order_by = ();
    1610 0           $query .= " ORDER BY ";
    1611 0           $jquery .= " ORDER BY ";
    1612 0           foreach my $col (@sort_by)
    1613             {
    1614 0 0         if ($col =~ /^-(.*)/)
    1615             {
    1616 0           push @order_by, "$1 DESC";
    1617             }
    1618             else
    1619             {
    1620 0           push @order_by, $col;
    1621             }
    1622             }
    1623 0           $query .= join(', ', @order_by);
    1624 0           $jquery .= join(', ', @order_by);
    1625             }
    1626 0 0         if ($limit)
    1627             {
    1628 0           $query .= " LIMIT $limit";
    1629 0           $jquery .= " LIMIT $limit";
    1630             }
    1631 0 0         if ($offset)
    1632             {
    1633 0           $query .= " OFFSET $offset";
    1634 0           $jquery .= " OFFSET $offset";
    1635             }
    1636 0 0         my $total = (defined $args{total}
    1637             ? $args{total}
    1638             : $self->get_total_matching(%args));
    1639              
    1640             # actual query
    1641 0           my $sth1;
    1642 0           $sth1 = $self->{dbh}->prepare($query);
    1643 0 0         if (!$sth1)
    1644             {
    1645 0           $self->print_message("Can't prepare query $query: $DBI::errstr");
    1646 0           return 0;
    1647             }
    1648 0           my $rv = $sth1->execute();
    1649 0 0         if (!$rv)
    1650             {
    1651 0           $self->print_message("Can't execute query $query: $DBI::errstr");
    1652 0           return 0;
    1653             }
    1654              
    1655             # make a "join-like" query of the second table
    1656             # first figure out the correct value of the join field
    1657             # then make the actual query
    1658 0           my $sth2;
    1659 0           my $t2query = '';
    1660 0 0 0       if (($total == 1 or $limit == 1)
          0        
    1661             and $table2)
    1662             {
    1663 0           my $sth_jq = $self->{dbh}->prepare($jquery);
    1664 0 0         if (!$sth_jq)
    1665             {
    1666 0           $self->print_message("Can't prepare query $jquery: $DBI::errstr");
    1667 0           return 0;
    1668             }
    1669 0           my $rv = $sth_jq->execute();
    1670 0 0         if (!$rv)
    1671             {
    1672 0           $self->print_message("Can't execute query $jquery: $DBI::errstr");
    1673 0           return 0;
    1674             }
    1675 0           my $join_val;
    1676             my @row;
    1677 0           while (@row = $sth_jq->fetchrow_array)
    1678             {
    1679 0           $join_val = $row[0];
    1680             }
    1681              
    1682             # make the query for the second table
    1683 0           my @cols2 = $self->get_colnames($table2);
    1684 0           $t2query = "SELECT ";
    1685 0           $t2query .= join(', ', @cols2);
    1686 0           $t2query .= " FROM $table2 ";
    1687 0 0         if ($self->col_is_int(table=>$table2, column=>$join_col))
    1688             {
    1689 0           $t2query .= "WHERE $join_col = $join_val";
    1690             }
    1691             else
    1692             {
    1693 0           $t2query .= "WHERE $join_col = '$join_val'";
    1694             }
    1695 0           $sth2 = $self->{dbh}->prepare($t2query);
    1696 0 0         if (!$sth2)
    1697             {
    1698 0           $self->print_message("Can't prepare query $t2query: $DBI::errstr");
    1699 0           return 0;
    1700             }
    1701 0           $rv = $sth2->execute();
    1702 0 0         if (!$rv)
    1703             {
    1704 0           $self->print_message("Can't execute query $t2query: $DBI::errstr");
    1705 0           return 0;
    1706             }
    1707             }
    1708 0           return ($sth1, $sth2);
    1709             } # make_selections
    1710              
    1711             =head2 get_tables
    1712              
    1713             my @tables = $self->get_tables();
    1714              
    1715             my @tables = $self->get_tables(views=>0);
    1716              
    1717             Get the names of the tables (and views) in the database.
    1718              
    1719             =cut
    1720             sub get_tables {
    1721 0     0 1   my $self = shift;
    1722 0           my %args = (
    1723             views=>1,
    1724             @_
    1725             );
    1726              
    1727 0           my @tables = ();
    1728 0           my $query = "SELECT name from sqlite_master ";
    1729 0 0         if ($args{views})
    1730             {
    1731 0           $query .= "WHERE type = 'table' OR type = 'view'";
    1732             }
    1733             else
    1734             {
    1735 0           $query .= "WHERE type = 'table'";
    1736             }
    1737 0           my $sth = $self->{dbh}->prepare($query);
    1738 0 0         if (!$sth)
    1739             {
    1740 0           $self->print_message("Can't prepare query $query: $DBI::errstr");
    1741 0           return 0;
    1742             }
    1743 0           my $rv = $sth->execute();
    1744 0 0         if (!$rv)
    1745             {
    1746 0           $self->print_message("Can't execute query $query: $DBI::errstr");
    1747 0           return 0;
    1748             }
    1749 0           my @row;
    1750 0           while (@row = $sth->fetchrow_array)
    1751             {
    1752 0           push @tables, $row[0];
    1753             }
    1754 0           return @tables;
    1755             } # get_tables
    1756              
    1757             =head2 get_colnames
    1758              
    1759             my @columns = $self->get_colnames($table);
    1760              
    1761             my @columns = $self->get_colnames($table, do_rowid=>0);
    1762              
    1763             Get the column names of the given table.
    1764              
    1765             =cut
    1766             sub get_colnames {
    1767 0     0 1   my $self = shift;
    1768 0           my $table = shift;
    1769 0           my %args = (
    1770             do_rowid=>1,
    1771             @_
    1772             );
    1773              
    1774 0 0         my @columns = ($args{do_rowid}
        0          
    1775             ? ($self->get_id_colname($table) eq 'rowid' ? qw(rowid) : () )
    1776             : ());
    1777 0           my $query = "PRAGMA table_info('$table')";
    1778 0           my $sth = $self->{dbh}->prepare($query);
    1779 0 0         if (!$sth)
    1780             {
    1781 0           $self->print_message("Can't prepare query $query: $DBI::errstr");
    1782 0           return 0;
    1783             }
    1784 0           my $rv = $sth->execute();
    1785 0 0         if (!$rv)
    1786             {
    1787 0           $self->print_message("Can't execute query $query: $DBI::errstr");
    1788 0           return 0;
    1789             }
    1790 0           my $row_hash;
    1791 0           while ($row_hash = $sth->fetchrow_hashref)
    1792             {
    1793 0           push @columns, $row_hash->{'name'};
    1794             }
    1795              
    1796 0           return @columns;
    1797             } # get_colnames
    1798              
    1799             =head2 get_distinct_col
    1800              
    1801             @vals = $rep->get_distinct_col(
    1802             table=>$table,
    1803             colname=>$colname,
    1804             where=>\%where,
    1805             not_where=>\%not_where,
    1806             );
    1807              
    1808             Get all the distinct values for the given column
    1809             (which match the selection criteria).
    1810              
    1811             =cut
    1812             sub get_distinct_col {
    1813 0     0 1   my $self = shift;
    1814 0           my %args = (
    1815             table=>undef,
    1816             colname=>'',
    1817             not_where=>{},
    1818             where=>{},
    1819             @_
    1820             );
    1821 0           my $table = $args{table};
    1822 0           my $colname = $args{colname};
    1823              
    1824             # build up the query data
    1825 0           my @where = $self->build_where_conditions(%args,
    1826             where=>$args{where}, not_where=>$args{not_where});
    1827            
    1828 0           my $query = "SELECT DISTINCT $colname FROM $table";
    1829 0 0         if (@where)
    1830             {
    1831 0           $query .= " WHERE " . join(" AND ", @where);
    1832             }
    1833 0           $query .= " ORDER BY $colname";
    1834 0           my $sth = $self->{dbh}->prepare($query);
    1835 0 0         if (!$sth)
    1836             {
    1837 0           $self->print_message("Can't prepare query $query: $DBI::errstr");
    1838 0           return 0;
    1839             }
    1840 0           my $rv = $sth->execute();
    1841 0 0         if (!$rv)
    1842             {
    1843 0           $self->print_message("Can't execute query $query: $DBI::errstr");
    1844 0           return 0;
    1845             }
    1846 0           my @vals = ();
    1847 0           my @row;
    1848 0           while (@row = $sth->fetchrow_array)
    1849             {
    1850 0           push @vals, $row[0];
    1851             }
    1852 0           return @vals;
    1853             } # get_distinct_col
    1854              
    1855             =head1 Private Methods
    1856              
    1857             =head2 print_select
    1858              
    1859             Print a selection result.
    1860              
    1861             =cut
    1862             sub print_select {
    1863 0     0 1   my $self = shift;
    1864 0           my $sth = shift;
    1865 0           my $sth2 = shift;
    1866 0           my %args = (
    1867             table=>'',
    1868             title=>'',
    1869             command=>'Search',
    1870             prev_file=>'',
    1871             prev_label=>'Prev',
    1872             next_file=>'',
    1873             next_label=>'Next',
    1874             prev_next_template=>'',
    1875             @_
    1876             );
    1877 0           my @columns = @{$args{columns}};
      0            
    1878 0           my $table = $args{table};
    1879 0           my $page = $args{page};
    1880              
    1881             # read the template
    1882 0           my $template = $self->get_template($self->{report_template});
    1883 0           $self->{report_template} = $template;
    1884              
    1885 0 0         my $num_pages = ($args{limit} ? ceil($args{total} / $args{limit}) : 1);
    1886             # generate the HTML table
    1887 0           my $count = 0;
    1888 0           my $res_tab = '';
    1889 0           ($count, $res_tab) = $self->format_report($sth,
    1890             %args,
    1891             table=>$table,
    1892             table2=>$args{table2},
    1893             columns=>\@columns,
    1894             sort_by=>$args{sort_by},
    1895             num_pages=>$num_pages,
    1896             );
    1897 0 0         my $main_title = ($args{title} ? $args{title}
    1898             : "$table $args{command} result");
    1899 0 0         my $title = ($args{limit} ? "$main_title ($page)"
    1900             : $main_title);
    1901             # fix up random apersands
    1902 0 0         if ($title =~ / & /)
    1903             {
    1904 0           $title =~ s/ & / & /g;
    1905             }
    1906 0           my @result = ();
    1907 0           push @result, $res_tab;
    1908 0 0 0       push @result, "

    $count rows displayed of $args{total}.

    \n"
    1909             if ($args{report_style} ne 'bare'
    1910             and $args{report_style} ne 'compact');
    1911 0 0 0       if ($args{limit} and $args{report_style} eq 'full')
    1912             {
    1913 0           push @result, "

    Page $page of $num_pages.

    \n"
    1914             }
    1915 0 0         if (defined $sth2)
    1916             {
    1917 0           my @cols2 = $self->get_colnames($args{table2});
    1918 0           my $count2;
    1919             my $tab2;
    1920 0           ($count2, $tab2) = $self->format_report($sth2,
    1921             %args,
    1922             table=>$args{table2},
    1923             columns=>\@cols2,
    1924             sort_by=>\@cols2,
    1925             headers=>[],
    1926             groups=>[],
    1927             row_template=>'',
    1928             num_pages=>0,
    1929             );
    1930 0 0         if ($count2)
    1931             {
    1932 0           push @result,<
    1933            

    $args{table2}

    1934             $tab2
    1935            

    $count2 rows displayed from $args{table2}.

    1936             EOT
    1937             }
    1938             }
    1939              
    1940             # prepend the message
    1941 0 0         unshift @result, "

    $self->{message}

    \n", if $self->{message};
    1942              
    1943             # append the prev-next links, if any
    1944 0 0 0       if ($args{prev_file} or $args{next_file})
    1945             {
    1946 0           my $prev_label = $args{prev_label};
    1947 0           my $next_label = $args{next_label};
    1948 0           my %pn_hash = (
    1949             prev_file => $args{prev_file},
    1950             prev_label => $prev_label,
    1951             next_file => $args{next_file},
    1952             next_label => $next_label,
    1953             );
    1954 0 0         my $pn_template = ($args{prev_next_template}
    1955             ? $args{prev_next_template}
    1956             : '
    1957            

    {?prev_file [$prev_label]}

    1958             {?next_file [$next_label]}
    1959            

    1960             '
    1961             );
    1962 0           my $pn_templ = $self->get_template($pn_template);
    1963 0           my $pn_str = $self->{_tobj}->fill_in(data_hash=>\%pn_hash,
    1964             template=>$pn_templ);
    1965 0           push @result, $pn_str;
    1966             }
    1967              
    1968 0           my $contents = join('', @result);
    1969 0           my $out = $template;
    1970 0           $out =~ s//$title/g;
    1971 0           $out =~ s//$contents/g;
    1972             # Now print the page for the user to see...
    1973 0 0 0       if (!defined $args{outfile}
          0        
    1974             or $args{outfile} eq ''
    1975             or $args{outfile} eq '-')
    1976             {
    1977 0           print $out;
    1978             }
    1979             else
    1980             {
    1981 0           my $fh;
    1982 0 0         open($fh, ">", $args{outfile})
    1983             or die "Could not open $args{outfile} for writing";
    1984 0           print $fh $out;
    1985 0           close($fh);
    1986             }
    1987             } # print_select
    1988              
    1989             =head2 get_template
    1990              
    1991             my $templ = $self->get_template($template);
    1992              
    1993             Get the given template (read if it's from a file)
    1994              
    1995             =cut
    1996             sub get_template {
    1997 0     0 1   my $self = shift;
    1998 0           my $template = shift;
    1999              
    2000 0 0 0       if ($template !~ /\n/
    2001             && -r $template)
    2002             {
    2003 0           local $/ = undef;
    2004 0           my $fh;
    2005 0 0         open($fh, $template)
    2006             or die "Could not open ", $template;
    2007 0           $template = <$fh>;
    2008 0           close($fh);
    2009             }
    2010 0           return $template;
    2011             } # get_template
    2012              
    2013             =head2 get_id_colname
    2014              
    2015             $id_colname = $self->get_id_colname($table);
    2016              
    2017             Get the name of the column which is used for row-identification.
    2018             (Most of the time it is just 'rowid')
    2019              
    2020             =cut
    2021             sub get_id_colname {
    2022 0     0 1   my $self = shift;
    2023 0           my $table = shift;
    2024              
    2025 0 0 0       if (exists $self->{row_ids}->{$table}
    2026             and defined $self->{row_ids}->{$table})
    2027             {
    2028 0           return $self->{row_ids}->{$table};
    2029             }
    2030 0           return 'rowid';
    2031             } # get_id_colname
    2032              
    2033             =head2 get_join_colname
    2034              
    2035             $join_col = $self->get_join_colname($table1, $table2);
    2036              
    2037             Get the name of the column which is used to join these two tables.
    2038              
    2039             =cut
    2040             sub get_join_colname {
    2041 0     0 1   my $self = shift;
    2042 0           my $table = shift;
    2043 0           my $table2 = shift;
    2044              
    2045 0           my $key1 = "$table+$table2";
    2046 0           my $key2 = "$table2+$table";
    2047 0 0 0       if (exists $self->{join_cols}->{$key1}
        0 0        
    2048             and defined $self->{join_cols}->{$key1})
    2049             {
    2050 0           return $self->{join_cols}->{$key1};
    2051             }
    2052             elsif (exists $self->{join_cols}->{$key2}
    2053             and defined $self->{join_cols}->{$key2})
    2054             {
    2055 0           return $self->{join_cols}->{$key2};
    2056             }
    2057 0           return 'rowid';
    2058             } # get_join_colname
    2059              
    2060             =head2 col_is_int
    2061              
    2062             my $res = $self->col_is_int(table=>$table, column=>$column);
    2063              
    2064             Checks the column type of the given column in the given table;
    2065             returns true if it is an integer type.
    2066              
    2067             =cut
    2068             sub col_is_int {
    2069 0     0 1   my $self = shift;
    2070 0           my %args = (
    2071             table=>'',
    2072             column=>'rowid',
    2073             @_
    2074             );
    2075 0           my $table = $args{table};
    2076 0           my $column = $args{column};
    2077              
    2078 0           my $query = "PRAGMA table_info('$table')";
    2079 0           my $sth = $self->{dbh}->prepare($query);
    2080 0 0         if (!$sth)
    2081             {
    2082 0           $self->print_message("Can't prepare query $query: $DBI::errstr");
    2083 0           return 0;
    2084             }
    2085 0           my $rv = $sth->execute();
    2086 0 0         if (!$rv)
    2087             {
    2088 0           $self->print_message("Can't execute query $query: $DBI::errstr");
    2089 0           return 0;
    2090             }
    2091 0           my $row_hash;
    2092 0           while ($row_hash = $sth->fetchrow_hashref)
    2093             {
    2094 0 0         if ($row_hash->{name} eq $column)
    2095             {
    2096 0 0         if ($row_hash->{type} =~ /character/)
        0          
        0          
    2097             {
    2098 0           return 0;
    2099             }
    2100             elsif ($row_hash->{type} =~ /integer/)
    2101             {
    2102 0           return 1;
    2103             }
    2104             elsif ($row_hash->{type} =~ /smallint/)
    2105             {
    2106 0           return 1;
    2107             }
    2108             }
    2109             }
    2110              
    2111 0           return 0;
    2112             } # col_is_int
    2113              
    2114             =head2 format_report
    2115              
    2116             $my report = $self->format_report(
    2117             table=>$table,
    2118             command=>'Search',
    2119             columns=>\@columns,
    2120             force_show_cols=>\%force_show_cols,
    2121             sort_by=>\@sort_by,
    2122             headers=>\@headers,
    2123             header_start=>1,
    2124             table2=>$table2,
    2125             layout=>'table',
    2126             row_template=>$row_template,
    2127             report_style=>'compact',
    2128             table_header=>$thead,
    2129             table_border=>1,
    2130             table_class=>'plain',
    2131             truncate_colnames=>0,
    2132             );
    2133              
    2134             Construct a HTML result table
    2135              
    2136             =cut
    2137             sub format_report {
    2138 0     0 1   my $self = shift;
    2139 0           my $sth = shift;
    2140 0           my %args = (
    2141             table=>'',
    2142             command=>'Search',
    2143             layout=>'table',
    2144             row_template=>'',
    2145             report_style=>'full',
    2146             table_header=>'',
    2147             force_show_cols=>{},
    2148             @_
    2149             );
    2150 0           my @columns = @{$args{columns}};
      0            
    2151 0           my @sort_by = (!defined $args{sort_by}
    2152             ? ()
    2153             : (!ref $args{sort_by}
    2154             ? split(' ', $args{sort_by})
    2155 0 0         : @{$args{sort_by}}));
        0          
    2156 0           my @headers = @{$args{headers}};
      0            
    2157 0   0       my $header_start = $args{header_start} || 1;
    2158 0           my @groups = @{$args{groups}};
      0            
    2159 0           my %force_show_cols = %{$args{force_show_cols}};
      0            
    2160 0           my $command = $args{command};
    2161 0           my $table = $args{table};
    2162 0           my $table2 = $args{table2};
    2163 0           my $report_style = $args{report_style};
    2164 0           my $table_border = $args{table_border};
    2165 0           my $table_class = $args{table_class};
    2166 0           my $truncate_colnames = $args{truncate_colnames};
    2167              
    2168             # change things depending on report_style
    2169 0 0         if (!defined $table_border)
    2170             {
    2171 0 0         if ($report_style eq 'bare')
    2172             {
    2173 0           $table_border = 0;
    2174             }
    2175             else
    2176             {
    2177 0           $table_border = 1;
    2178             }
    2179             }
    2180 0 0         if (!defined $table_class)
    2181             {
    2182 0 0         if ($report_style eq 'bare')
    2183             {
    2184 0           $table_class = '';
    2185             }
    2186             else
    2187             {
    2188 0           $table_class = 'plain';
    2189             }
    2190             }
    2191 0 0         if (!defined $truncate_colnames)
    2192             {
    2193 0 0         if ($report_style eq 'full')
        0          
        0          
    2194             {
    2195 0           $truncate_colnames = 0;
    2196             }
    2197             elsif ($report_style eq 'medium')
    2198             {
    2199 0           $truncate_colnames = 6;
    2200             }
    2201             elsif ($report_style eq 'compact')
    2202             {
    2203 0           $truncate_colnames = 4;
    2204             }
    2205             else
    2206             {
    2207 0           $truncate_colnames = 0;
    2208             }
    2209             }
    2210              
    2211 0           my @out = ();
    2212 0           my $count = 0;
    2213 0           my $row_id_name = $self->get_id_colname($table);
    2214 0           my $row_id_ind;
    2215             # by default, show all columns
    2216 0           my %show_cols = ();
    2217 0           for (my $i = 0; $i < @columns; $i++)
    2218             {
    2219 0           $show_cols{$columns[$i]} = 1;
    2220 0 0         if ($columns[$i] eq $row_id_name)
    2221             {
    2222 0           $row_id_ind = $i;
    2223             }
    2224             }
    2225              
    2226             # make headers for all the headers
    2227             # set the headers and entry columns
    2228 0           my %prev_head = ();
    2229 0 0 0       if (@sort_by and @headers)
    2230             {
    2231 0   0       for (my $i=0; $i < @headers && $i < @sort_by; $i++)
    2232             {
    2233 0           $prev_head{$i} = '';
    2234             # read each header template if it's a file
    2235 0           $headers[$i] = $self->get_template($headers[$i]);
    2236             # read each 'group' template if the template is a file
    2237 0 0 0       if (@groups and exists $groups[$i] and defined $groups[$i])
          0        
    2238             {
    2239 0           $groups[$i] = $self->get_template($groups[$i]);
    2240             }
    2241             }
    2242              
    2243             # find out what fields are in the headers and groups
    2244 0           my %in_header = ();
    2245 0           my $all_headers = join('', @headers, @groups);
    2246 0           while ($all_headers =~ m/{\$(\w+)[:\w]*}/)
    2247             {
    2248 0           $in_header{$1} = 1;
    2249 0           $all_headers =~ s/{\$\w+[:\w]*}//;
    2250             }
    2251 0           while ($all_headers =~ m/\[\$(\w+)[:\w]*\]/)
    2252             {
    2253 0           $in_header{$1} = 1;
    2254 0           $all_headers =~ s/\[\$\w+[:\w]*\]//;
    2255             }
    2256 0           for my $col (@columns)
    2257             {
    2258 0 0 0       if ($in_header{$col} && !$force_show_cols{$col})
    2259             {
    2260 0           $show_cols{$col} = 0;
    2261             }
    2262             }
    2263             }
    2264             #
    2265             # Set the nicer column name labels
    2266 0           my %nice_cols = $self->set_nice_cols(truncate_colnames=>$truncate_colnames,
    2267             columns=>\@columns);
    2268              
    2269 0           my $row_template = $self->get_row_template(
    2270             table=>$table,
    2271             row_template=>$args{row_template},
    2272             layout=>$args{layout},
    2273             report_style=>$args{report_style},
    2274             columns=>\@columns,
    2275             show_cols=>\%show_cols,
    2276             nice_cols=>\%nice_cols);
    2277 0           my $thead = $self->get_template($args{table_header});
    2278 0 0 0       if (%nice_cols and !$thead)
    2279             {
    2280 0           $thead .= '
    2281 0           foreach my $col (@columns)
    2282             {
    2283 0 0         if ($show_cols{$col})
    2284             {
    2285 0           my $nicecol = $nice_cols{$col};
    2286 0           $thead .= "$nicecol
    2287             }
    2288             }
    2289 0           $thead .= "
    2290             }
    2291              
    2292 0 0 0       my $page = ((defined $args{num_pages} and $args{num_pages} > 1)
    2293             ? $args{page} : 0);
    2294             # process the rows
    2295 0           my $new_section = 1;
    2296 0           my $row_hash;
    2297 0           while ($row_hash = $sth->fetchrow_hashref)
    2298             {
    2299             # add the page-number to the data
    2300 0           $row_hash->{_page} = $page;
    2301 0           $row_hash->{_num_pages} = $args{num_pages};
    2302 0 0         if (@headers)
    2303             {
    2304 0           for (my $hi = 0; $hi < @headers; $hi++)
    2305             {
    2306 0           my $hval = $headers[$hi];
    2307 0 0         $hval = '' if !$hval;
    2308 0           $hval =~ s/{([^}]+)}/$self->{_tobj}->do_replace(data_hash=>$row_hash,targ=>$1)/eg;
      0            
    2309 0           my $gval = $groups[$hi];
    2310 0 0         $gval = '' if !$gval;
    2311 0           $gval =~ s/{([^}]+)}/$self->{_tobj}->do_replace(data_hash=>$row_hash,targ=>$1)/eg;
      0            
    2312 0 0 0       if ($hval
    2313             and $hval ne $prev_head{$hi})
    2314             {
    2315 0 0 0       if ($count != 0 && !$new_section)
    2316             {
    2317 0           push @out, $self->end_section(type=>$args{layout});
    2318 0           $new_section = 1;
    2319             }
    2320             # only make a header if it has content
    2321 0 0         push @out, sprintf("%s\n",
    2322             $hi + $header_start, $hval, $hi + $header_start)
    2323             if $hval;
    2324             # and group content, if there is any
    2325 0 0         push @out, "

    $gval

    \n", if $gval;
    2326 0           $prev_head{$hi} = $hval;
    2327             }
    2328             }
    2329             }
    2330 0 0         if ($new_section)
    2331             {
    2332 0           push @out, $self->start_section(type=>$args{layout},
    2333             table_border=>$table_border,
    2334             table_class=>$table_class);
    2335 0 0 0       if ($report_style ne 'bare'
    2336             and $args{layout} eq 'table')
    2337             {
    2338 0           push @out, $thead;
    2339             }
    2340 0           $new_section = 0;
    2341             }
    2342 0           my $rowstr = $row_template;
    2343 0           $rowstr =~ s/{([^}]+)}/$self->{_tobj}->do_replace(data_hash=>$row_hash,show_names=>\%show_cols,targ=>$1)/eg;
      0            
    2344 0           push @out, $rowstr;
    2345 0           $count++;
    2346             } # for each row
    2347 0           push @out, $self->end_section(type=>$args{layout});
    2348              
    2349 0           my $out_str = join('', @out);
    2350 0           return ($count, $out_str);
    2351             } # format_report
    2352              
    2353             =head2 get_row_template
    2354              
    2355             $row_template = $self->get_row_template(
    2356             table=>$table,
    2357             row_template=>$rt,
    2358             layout=>'table',
    2359             columns=>\@columns,
    2360             show_cols=>\%show_cols,
    2361             nice_cols=>\%nice_cols,
    2362             );
    2363              
    2364             Get or set or create the row template.
    2365              
    2366             =cut
    2367             sub get_row_template {
    2368 0     0 1   my $self = shift;
    2369 0           my %args = (
    2370             table=>'',
    2371             row_template=>'',
    2372             layout=>'table',
    2373             report_style=>'full',
    2374             columns=>undef,
    2375             show_cols=>undef,
    2376             nice_cols=>undef,
    2377             @_
    2378             );
    2379              
    2380 0           my $row_template = $args{row_template};
    2381             # read in the file if it's a file
    2382 0 0 0       if ($row_template !~ /\n/ && -r $row_template)
    2383             {
    2384 0           my $fh;
    2385 0 0         open($fh, $row_template)
    2386             or die "could not open $row_template: $!";
    2387 0           local $/;
    2388 0           $row_template = <$fh>;
    2389 0           close($fh);
    2390             }
    2391 0 0         if (!$row_template)
    2392             {
    2393 0           my @rt = ();
    2394 0 0 0       if ($args{layout} eq 'table')
        0          
        0          
        0          
        0          
    2395             {
    2396 0           push @rt, "
    2397 0           foreach my $col (@{$args{columns}})
      0            
    2398             {
    2399 0 0         if ($args{show_cols}->{$col})
    2400             {
    2401 0           push @rt, "{?$col [\$$col";
    2402 0 0         push @rt, ':',
    2403             $self->{default_format}->{$args{table}}->{$col}
    2404             if ($self->{default_format}->{$args{table}}->{$col});
    2405 0           push @rt, "]!! }
    2406             }
    2407             }
    2408 0           push @rt, "
    2409             }
    2410             elsif ($args{layout} eq 'para')
    2411             {
    2412 0           push @rt, "

    ";

    2413 0           foreach my $col (@{$args{columns}})
      0            
    2414             {
    2415 0 0         if ($args{show_cols}->{$col})
    2416             {
    2417 0 0         if ($args{report_style} ne 'bare')
    2418             {
    2419 0           push @rt, "{?$col ";
    2420 0           push @rt, $args{nice_cols}->{$col};
    2421 0           push @rt, ": ";
    2422             }
    2423 0           push @rt, "[\$";
    2424 0           push @rt, $col;
    2425 0 0         push @rt, ':',
    2426             $self->{default_format}->{$args{table}}->{$col}
    2427             if ($self->{default_format}->{$args{table}}->{$col});
    2428 0           push @rt, "]
    }\n";
    2429             }
    2430             }
    2431 0           push @rt, "

    \n";
    2432             }
    2433             elsif ($args{layout} eq 'list')
    2434             {
    2435 0           push @rt, "
  • ";
  • 2436 0           foreach my $col (@{$args{columns}})
      0            
    2437             {
    2438 0 0         if ($args{show_cols}->{$col})
    2439             {
    2440 0           push @rt, "{\$$col";
    2441 0 0         push @rt, ':',
    2442             $self->{default_format}->{$args{table}}->{$col}
    2443             if ($self->{default_format}->{$args{table}}->{$col});
    2444 0           push @rt, "}\n";
    2445             }
    2446             }
    2447 0           push @rt, "\n";
    2448             }
    2449             elsif ($args{layout} eq 'fieldval')
    2450             {
    2451             # field:value
    2452 0           foreach my $col (@{$args{columns}})
      0            
    2453             {
    2454 0 0         if ($args{show_cols}->{$col})
    2455             {
    2456 0           push @rt, "$col:{\$$col";
    2457 0 0         push @rt, ':',
    2458             $self->{default_format}->{$args{table}}->{$col}
    2459             if ($self->{default_format}->{$args{table}}->{$col});
    2460 0           push @rt, "}\n";
    2461             }
    2462             }
    2463 0           push @rt, "=\n";
    2464             }
    2465             elsif ($args{layout} eq '' or $args{layout} eq 'none')
    2466             {
    2467             # one value on each line, no HTML
    2468 0           foreach my $col (@{$args{columns}})
      0            
    2469             {
    2470 0 0         if ($args{show_cols}->{$col})
    2471             {
    2472 0           push @rt, "{\$$col";
    2473 0 0         push @rt, ':',
    2474             $self->{default_format}->{$args{table}}->{$col}
    2475             if ($self->{default_format}->{$args{table}}->{$col});
    2476 0           push @rt, "}\n";
    2477             }
    2478             }
    2479             }
    2480 0           $row_template = join('', @rt);
    2481             }
    2482              
    2483 0           return $row_template;
    2484             } # get_row_template
    2485              
    2486             =head2 set_nice_cols
    2487              
    2488             %nice_cols = $self->set_nice_cols(
    2489             truncate_colnames=>0,
    2490             columns=>\@columns);
    2491              
    2492             =cut
    2493             sub set_nice_cols {
    2494 0     0 1   my $self = shift;
    2495 0           my %args = (
    2496             columns=>[],
    2497             truncate_colnames=>0,
    2498             @_
    2499             );
    2500 0           my $truncate_colnames = $args{truncate_colnames};
    2501              
    2502             # Set the nicer column name labels
    2503 0           my %nice_cols = ();
    2504 0           foreach my $col (@{$args{columns}})
      0            
    2505             {
    2506 0           my $nicecol = $col;
    2507 0 0         if ($truncate_colnames)
    2508             {
    2509 0           my @colwords = split('_', $nicecol);
    2510 0           foreach my $cw (@colwords)
    2511             {
    2512 0           $cw = $self->{_tobj}->convert_value(value=>$cw,
    2513             format=>"trunc${truncate_colnames}",
    2514             name=>$col);
    2515 0           $cw = $self->{_tobj}->convert_value(value=>$cw,
    2516             format=>'proper',
    2517             name=>$col);
    2518             }
    2519 0           $nicecol = join(' ', @colwords);
    2520             }
    2521             else
    2522             {
    2523 0           $nicecol =~ s/_/ /g;
    2524 0           $nicecol = $self->{_tobj}->convert_value(value=>$nicecol,
    2525             format=>'proper', name=>$col);
    2526             }
    2527 0           $nice_cols{$col} = $nicecol;
    2528             }
    2529 0           return %nice_cols;
    2530             } # set_nice_cols
    2531              
    2532             =head2 start_section
    2533              
    2534             $sect = $self->start_section(type=>'table',
    2535             table_border=>$table_border,
    2536             table_class=>$table_class);
    2537              
    2538             Start a new table/para/list
    2539             The 'table_border' option is the border-size of the table
    2540             if using table style
    2541             The 'table_class' option is the class of the table
    2542             if using table style
    2543              
    2544             =cut
    2545             sub start_section {
    2546 0     0 1   my $self = shift;
    2547 0           my %args = (
    2548             type=>'table',
    2549             table_border=>1,
    2550             @_
    2551             );
    2552              
    2553 0 0         if ($args{type} eq 'table')
        0          
        0          
    2554             {
    2555 0 0         return sprintf('',
        0          
    2556             ($args{table_border} ? ' border="' . $args{table_border} . '"' : ''),
    2557             ($args{table_class} ? ' class="' . $args{table_class} . '"' : ''));
    2558             }
    2559             elsif ($args{type} eq 'para')
    2560             {
    2561 0           return '';
    2562             }
    2563             elsif ($args{type} eq 'list')
    2564             {
    2565 0           return "
      \n";
    2566             }
    2567 0           '';
    2568             } # start_section
    2569              
    2570             =head2 end_section
    2571              
    2572             $sect = $self->end_section(type=>'table');
    2573              
    2574             End an old table/para/list
    2575              
    2576             =cut
    2577             sub end_section {
    2578 0     0 1   my $self = shift;
    2579 0           my %args = (
    2580             type=>'table',
    2581             @_
    2582             );
    2583              
    2584 0 0         if ($args{type} eq 'table')
        0          
        0          
    2585             {
    2586 0           return "
    \n"; 2587             } 2588             elsif ($args{type} eq 'para') 2589             { 2590 0           return "\n"; 2591             } 2592             elsif ($args{type} eq 'list') 2593             { 2594 0           return "\n\n"; 2595             } 2596 0           ''; 2597             } # end_section 2598               2599             =head2 build_where_conditions 2600               2601             Take the %where, %not_where hashes and make an array of SQL conditions. 2602               2603             @where = $self->build_where_conditions(where=>\%where, 2604             not_where=>\%not_where); 2605               2606             =cut 2607             sub build_where_conditions { 2608 0     0 1   my $self = shift; 2609 0           my %args = ( 2610             not_where=>{}, 2611             where=>{}, 2612             @_ 2613             ); 2614               2615 0           my @where = (); 2616 0           while (my ($col, $val) = each(%{$args{where}}))   0             2617             { 2618 0 0 0       if (!defined $val or $val eq 'NULL')     0 0         2619             { 2620 0 0         if ($args{not_where}->{$col}) 2621             { 2622 0           push @where, "$col IS NOT NULL"; 2623             } 2624             else 2625             { 2626 0           push @where, "$col IS NULL"; 2627             } 2628             } 2629             elsif (!$val or $val eq "''") 2630             { 2631 0 0         if ($args{not_where}->{$col}) 2632             { 2633 0           push @where, "$col != ''"; 2634             } 2635             else 2636             { 2637 0           push @where, "$col = ''"; 2638             } 2639             } 2640             else 2641             { 2642 0 0         if ($args{not_where}->{$col}) 2643             { 2644 0           push @where, "$col NOT GLOB " . $self->{dbh}->quote($val); 2645             } 2646             else 2647             { 2648 0           push @where, "$col GLOB " . $self->{dbh}->quote($val); 2649             } 2650             } 2651             } 2652 0           return @where; 2653             } # build_where_conditions 2654               2655             =head1 BUGS 2656               2657             Please report any bugs or feature requests to the author. 2658               2659             =head1 AUTHOR 2660               2661             Kathryn Andersen (RUBYKAT) 2662             perlkat AT katspace dot com 2663             http://www.katspace.com 2664               2665             =head1 COPYRIGHT AND LICENCE 2666               2667             Copyright (c) 2005 by Kathryn Andersen 2668               2669             This program is free software; you can redistribute it and/or modify it 2670             under the same terms as Perl itself. 2671               2672             =cut 2673               2674             1; # End of SQLite::Work 2675             __END__