1 |
=pod |
2 |
|
3 |
=head1 NAME |
4 |
|
5 |
DBIx::PearlReports -- A Versatile Report Generator |
6 |
|
7 |
=head1 SYNOPSIS |
8 |
|
9 |
Using the SIMPLE mode |
10 |
|
11 |
use DBIx::PearlReports qw(:Simple); |
12 |
create ( |
13 |
-datasource => 'dbi:Pg:dbname=database;host=hostname', |
14 |
-query => 'SELECT * FROM customers ORDER BY state, city;' |
15 |
); |
16 |
|
17 |
or |
18 |
|
19 |
create ( |
20 |
-datasource => 'dbi:Pg:dbname=database;host=hostname', |
21 |
-query => 'SELECT * FROM customers ORDER BY state, city WHERE name = ? AND age = ?', |
22 |
-param => ['Tobi',34], |
23 |
); |
24 |
|
25 |
group ( |
26 |
-trigger => sub { $filed{state} }, |
27 |
-head => sub { "State: $field{state}\n" }, |
28 |
-foot => sub { "Average Age for $field{state}".rpavg($field{age}) } |
29 |
); |
30 |
|
31 |
group ( |
32 |
-trigger => sub { $field{city} }, |
33 |
-head => sub { "City: $field{city} (".rpcnt($field{name}.")\n" }, |
34 |
-foot => sub { "Total Customers in Customers in ". |
35 |
"$field{city}: ".rpcnt($field{name})."\n" } |
36 |
); |
37 |
|
38 |
body ( |
39 |
-contents => sub { "$field{firstname} $field{lastname} $field{age}\n" } |
40 |
); |
41 |
|
42 |
print makereport; |
43 |
|
44 |
PearlReports can also be used in an Object Oriented Context: |
45 |
|
46 |
#!/usr/sepp/bin/perl-5.8.0 |
47 |
use lib qw( /usr/pack/postgresql-7.3.2-ds/lib/site_perl /usr/isgtc/lib/perl); |
48 |
use DBIx::PearlReports; |
49 |
$r = DBIx::PearlReports::create ( ... ); |
50 |
$r->group( ... ); |
51 |
$r->body( ... ) |
52 |
print $r->makereport; |
53 |
|
54 |
|
55 |
=head1 DESCRIPTION |
56 |
|
57 |
B<PearlReports> is a system for pulling information from an SQL database and |
58 |
produce Reports from this information. B<PearlReports> provides a very |
59 |
flexible system for creating reports based on SQL queries |
60 |
|
61 |
While it is sufficient to use the simple statements provided by |
62 |
PearlReports to create your reports, the full power of perl is only a |
63 |
keystroke away. |
64 |
|
65 |
Creating a Report using the PearlReports involves writing a short perl |
66 |
script which first loads the PearlReports module: |
67 |
|
68 |
#!/usr/bin/perl |
69 |
use DBIx::PearlReports qw(:SIMPLE); |
70 |
|
71 |
Then you call the B<create> function to create a new report: |
72 |
|
73 |
create ( |
74 |
-username => 'myname', |
75 |
-datasource => 'dbi:Pg:dbname=customers', |
76 |
-query => 'SELECT * from customers ORDER by state,city' |
77 |
); |
78 |
|
79 |
When creating a report you have to define username and password for |
80 |
the database you want to access. Because different people may use the |
81 |
report. If you do not mention either the B<-username> or B<-password> |
82 |
arguments, the module will ask you to supply one at run time. |
83 |
|
84 |
The B<-datasource> argument defines which |
85 |
database this report is going to use. Check the DBI/DBD documentation |
86 |
for the syntax apropriate for your Database. In the example above we |
87 |
are accessing a PostgreSQL database called I<customers> which runs on |
88 |
the local host. The B<-query> argument of the create function defines |
89 |
the data we want to use in our report. |
90 |
|
91 |
A central element of PearlReports is the ability to work with groups of |
92 |
records. In this example the report contains two nested groups. Note that |
93 |
the data |
94 |
|
95 |
must arive from the database in an order which is comatible with the |
96 |
required groups. (Check the ORDER BY cause above). |
97 |
|
98 |
group |
99 |
( -trigger => sub { $field{state} }, |
100 |
-head => sub { "Customers from $field{state}\n" }, |
101 |
-foot => sub { "Avg Age for $field{state} Customer:". |
102 |
rpavg($field{age})."\n\n" } ); |
103 |
|
104 |
group |
105 |
( -trigger => sub { $field{zip} }, |
106 |
-head => sub { "Customers from $field{town}\n" }, |
107 |
-foot => sub { "Min Age in $field{town}:". |
108 |
rpmin($field{age})."\n" } ); |
109 |
|
110 |
|
111 |
Each group definition requires a trigger and either a header or a |
112 |
footer or both. Each argument of the group definition is a little perl |
113 |
function definition. The Trigger function gets called for each record |
114 |
in the query. Whenever the value returned from the |
115 |
function changes the group iterates. Each iteration of a group is |
116 |
enclosed by the apropriate header and footer. |
117 |
|
118 |
The B<$field{xxx}> variables refer to the columns of the query. |
119 |
The footer and the header (!) can contain agregation functions |
120 |
(rpmin, rpmax, rpbig, rpsmall, rpsum, rpavg). See the section below |
121 |
|
122 |
Finally the actual data can get printed. |
123 |
|
124 |
body |
125 |
( -contents => sub { "$field{firstname} $field{lastname} $field{age}\n" } ); |
126 |
|
127 |
The body function will get called for each row in the database and its |
128 |
return value will be printed into the report. |
129 |
|
130 |
When groups and body are set up you can create the actual report by |
131 |
executing: |
132 |
|
133 |
print makereport; |
134 |
|
135 |
When you want to make a new report using the existion database connection |
136 |
for another report, you can reset it with the command |
137 |
|
138 |
reset; |
139 |
|
140 |
=head2 METHODS |
141 |
|
142 |
All functions provided by PearlReports expect named arguments. |
143 |
|
144 |
=head3 create or new |
145 |
|
146 |
Defines the data the report should be based on. This involves |
147 |
configuring the parameters for accessing the database server as well |
148 |
as defining the query string. |
149 |
|
150 |
If you are working with the OO interface you can use b<new> instead |
151 |
of create to be more in line with established naming conventions. |
152 |
|
153 |
=over |
154 |
|
155 |
=item -username |
156 |
|
157 |
the username for the database. If this option is not set, PearlReports will |
158 |
prompt for a username. |
159 |
|
160 |
=item -password |
161 |
|
162 |
the password. If this option is not supplied PearlReports will prompt for a |
163 |
password. |
164 |
|
165 |
=item -datasource |
166 |
|
167 |
the DBI connect string. Check the DBI/DBD manpage for the syntax apropriate |
168 |
for your database. |
169 |
|
170 |
=item -handle |
171 |
|
172 |
instead of the previous 3 arguments you can also give PearlReports an |
173 |
existing database handle to use. |
174 |
|
175 |
=item -query |
176 |
|
177 |
A SELECT query |
178 |
|
179 |
=item -param |
180 |
|
181 |
If you use '?' placeholders in the query, you can supply contents for them |
182 |
using the reference to an arry holding the relevant data. |
183 |
|
184 |
=back |
185 |
|
186 |
|
187 |
=head2 group |
188 |
|
189 |
The 'salt' of most reports is that some grouping structure exists. The |
190 |
records in the report get collected into groups of records which bear |
191 |
some common feature. Each group can have a header and a footer. |
192 |
|
193 |
=over |
194 |
|
195 |
=item -trigger |
196 |
|
197 |
Is a pointer to a anonymous function. The function gets called for |
198 |
each row in the result of the query. Whenever the return value from |
199 |
this function changes the group goes into its next iteration. There |
200 |
are other events which can cause a new iteration: A higher order group |
201 |
goes into another iteration or the last record from the query has been |
202 |
consumed. |
203 |
|
204 |
=item -head and -foot |
205 |
|
206 |
After each iteration, the anonymouse functions pointed to by the head |
207 |
and foot options get executed. The return values from the functions |
208 |
are used as header and footer for the material inside the group. |
209 |
|
210 |
=back |
211 |
|
212 |
=head3 body |
213 |
|
214 |
The inner most 'group' of the report does have neither foot nor head, |
215 |
it has just a body which gets printed for every row in the query result. |
216 |
|
217 |
=over |
218 |
|
219 |
=item -contents |
220 |
|
221 |
Stores a pointer to an anonymous function which gets executed for each |
222 |
record returned by the query. |
223 |
|
224 |
=back |
225 |
|
226 |
=head3 makereport |
227 |
|
228 |
returns an array containing the report ... |
229 |
|
230 |
=head3 reset |
231 |
|
232 |
clears the group and body data from the report. This can be used to run a |
233 |
second report of the same database connection without reconnecting. |
234 |
|
235 |
=head2 AGGREGATE FUNCTIONS |
236 |
|
237 |
=head3 rpsum |
238 |
|
239 |
Builds the sum of all the values its argument takes during the |
240 |
traversal of the records in the current group iteration. |
241 |
|
242 |
=head3 rpmin, rpmax |
243 |
|
244 |
Finds the min and max values in a group iteration. |
245 |
|
246 |
=head3 rpsmall, rpbig |
247 |
|
248 |
Finds the first and last value when sorting alphabetically. |
249 |
|
250 |
=head3 rpcnt |
251 |
|
252 |
Count the rows in the current group iteration. |
253 |
|
254 |
=head3 rpavg |
255 |
|
256 |
The same as above only that the average gets calculated. |
257 |
|
258 |
=head2 HOW TO WRITE NEW AGGREGATE FUNCTIONS |
259 |
|
260 |
If you want to write your own aggregat functions. Follow the examples |
261 |
below. Note that the first two lines of each function are |
262 |
mandatory. The structure you store in the $arr is up to you. |
263 |
|
264 |
use PearlReports qw(:MyAgg); |
265 |
|
266 |
sub mycnt ($) { |
267 |
my $cnt = $aggmem->{counter}++; |
268 |
my $arr = \$aggmem->{array}->[$cnt]; |
269 |
$$arr++ |
270 |
return $$arr; |
271 |
} |
272 |
|
273 |
sub myavg ($) { |
274 |
my $cnt = $aggmem->{counter}++; |
275 |
my $arr = \$aggmem->{array}->[$cnt]; |
276 |
$$arr->{sum} += $_[0]; |
277 |
$$arr->{cnt}++; |
278 |
return $$arr->{sum} / $$arr->{cnt}; |
279 |
} |
280 |
|
281 |
If you create cool aggregate functions please drop me a line. |
282 |
|
283 |
=head1 HISTORY |
284 |
|
285 |
2002-06-12 to Initial ISGTC release |
286 |
2003-07-16 to Added -handle option |
287 |
2003-07-29 to Added -param option |
288 |
|
289 |
=head1 AUTHOR |
290 |
|
291 |
S<Tobias Oetiker E<lt>oetiker@ee.ethz.chE<gt>> |
292 |
|
293 |
=head1 COPYRIGHT |
294 |
|
295 |
(C) 2000 by ETH Zurich |
296 |
|
297 |
=head1 LICENSE |
298 |
|
299 |
This code is made available under the GNU General Public License |
300 |
Version 2.0 or later (see www.gnu.org) |
301 |
|
302 |
=cut |
303 |
|
304 |
package DBIx::PearlReports; |
305 |
|
306 |
use Carp; |
307 |
use strict; |
308 |
use DBI; |
309 |
use vars qw(%field $VERSION @EXPORT %EXPORT_TAGS @ISA); # it's a package global |
310 |
require Exporter; |
311 |
$VERSION=1.0; |
312 |
|
313 |
@ISA = qw(Exporter); |
314 |
@EXPORT = qw(%field rpmin rpmax rpsum rpcnt rpavg rpsmall rpbig); |
315 |
%EXPORT_TAGS = ('Simple' => [qw(create group body makereport reset)], |
316 |
'MyAgg' => [qw($aggmem)]); |
317 |
|
318 |
#prototypes |
319 |
sub argcheck ($$$$); |
320 |
sub autoself (@); |
321 |
sub ask ($;$); |
322 |
|
323 |
my $DefaultSelf; |
324 |
#implementation |
325 |
|
326 |
sub create { |
327 |
my %args = @_; |
328 |
my $self = {}; |
329 |
bless $self; |
330 |
$DefaultSelf = $self; # set default for SIMPLE use |
331 |
if (not exists $args{-handle}){ |
332 |
argcheck "create", \%args, [qw(-datasource -query)],[qw(-username -password -param)]; |
333 |
$args{-username} = ask('Username:') unless defined $args{-username}; |
334 |
$args{-password} = ask('password:',1) unless defined $args{-password}; |
335 |
} else { |
336 |
argcheck "create", \%args, [qw(-handle -query)],[(-param)]; |
337 |
$self->{dbh} = $args{-handle}; |
338 |
} |
339 |
$self->{NEW} = \%args; |
340 |
return $self; |
341 |
} |
342 |
|
343 |
sub new { |
344 |
return create @_; |
345 |
} |
346 |
|
347 |
sub group { |
348 |
my ($self, %args) = autoself @_; |
349 |
argcheck "group", \%args, [qw(-trigger)],[qw(-head -foot)]; |
350 |
$args{aggmem} = {}; # this will hold info from the groups aggmem calls |
351 |
push @{$self->{GROUPS}}, \%args; |
352 |
} |
353 |
|
354 |
sub body { |
355 |
my ($self, %args) = autoself @_; |
356 |
argcheck "body", \%args, [qw(-contents)],[]; |
357 |
croak "there can be only one body in a report" |
358 |
if exists $self->{BODY}->{-contents}; |
359 |
$self->{BODY}->{-contents} = $args{-contents}; |
360 |
} |
361 |
|
362 |
# Global variable providing static, group local memmory |
363 |
# for all agregat functions. |
364 |
my $aggmem; |
365 |
|
366 |
# reset GROUPS and BODY asignement of report; |
367 |
|
368 |
sub reset { |
369 |
my ($self, %args) = autoself @_; |
370 |
$self->{GROUPS} = []; |
371 |
$self->{BODY} = undef; |
372 |
} |
373 |
|
374 |
sub makereport { |
375 |
my ($self, %args) = autoself @_; |
376 |
# open the database and get the data |
377 |
if ( not defined $self->{dbh} ) { |
378 |
$self->{dbh} = DBI->connect( $self->{NEW}->{-datasource}, |
379 |
$self->{NEW}->{-username}, |
380 |
$self->{NEW}->{-password} |
381 |
) or croak $DBI::errstr; |
382 |
} |
383 |
|
384 |
$self->{sth} = $self->{dbh}->prepare_cached($self->{NEW}->{-query}) |
385 |
or croak $self->{dbh}->errstr; |
386 |
|
387 |
if ($self->{NEW}->{-param}){ |
388 |
my @param = @{$self->{NEW}->{-param}}; |
389 |
for(1..scalar(@param)){ |
390 |
#count from 1 to number_of_parameters including. |
391 |
#sql parameters start at 1. |
392 |
$self->{sth}->bind_param($_,shift @param); |
393 |
} |
394 |
} |
395 |
|
396 |
$self->{sth}->execute() or croak $self->{dbh}->errstr."\n\nQuery: $self->{NEW}->{-query}"; |
397 |
|
398 |
my @report; #this array holds the report |
399 |
|
400 |
# loop through query response |
401 |
while (my $row = $self->{sth}->fetchrow_hashref) { |
402 |
%field = %$row; |
403 |
my $cascade; |
404 |
my @headstack; |
405 |
my @footstack; |
406 |
foreach my $group (@{$self->{GROUPS}}) { |
407 |
# $aggmem is the temporery storage are for all aggmem functions |
408 |
# called within the current group |
409 |
|
410 |
$aggmem = $group->{aggmem}; # asign aggmem pointer |
411 |
|
412 |
#evaluate current value of the trigger functions |
413 |
my $trigval = &{$group->{-trigger}}; |
414 |
if (defined $cascade or not defined $group->{trigval} |
415 |
or $trigval ne $group->{trigval}){ |
416 |
$group->{trigval} = $trigval; |
417 |
|
418 |
# if the trigger fired, fall through all the lower groups |
419 |
# they have to rotate too |
420 |
$cascade = 1; |
421 |
|
422 |
$aggmem->{array} = []; # clear aggmem storage |
423 |
|
424 |
unshift @footstack, $group->{footsave} |
425 |
if defined $group->{-foot}; |
426 |
# OK, this is a bit of voodo. Because I want that you can use agregate |
427 |
# functions in the head section we store a pointer to a string |
428 |
# and push it into the report. For each record in the group this |
429 |
# string gets updated (through the pointer) |
430 |
my $string = ""; |
431 |
push @headstack, \$string; |
432 |
$group->{headref} = \$string; |
433 |
} |
434 |
$aggmem->{counter} = 0; # reset aggmem storage pointer |
435 |
${$group->{headref}} = &{$group->{-head}} if exists $group->{-head}; |
436 |
$group->{footsave} = &{$group->{-foot}} if exists $group->{-foot}; |
437 |
} |
438 |
push @report, @footstack; |
439 |
push @report, @headstack; |
440 |
push @report, &{$self->{BODY}->{-contents}} if defined $self->{BODY}; |
441 |
|
442 |
} |
443 |
my @footstack; |
444 |
foreach my $group (@{$self->{GROUPS}}) { |
445 |
unshift @footstack , $group->{footsave} |
446 |
if defined $group->{-foot}; |
447 |
} |
448 |
push @report, @footstack; |
449 |
$self->{sth}->finish; |
450 |
# $self->{dbh}->disconnect; |
451 |
# now we resolve all the -head pointers left in the report stack |
452 |
# and we only ship values back which evaluated to a defined value |
453 |
return grep {defined $_} map {ref $_ eq 'SCALAR' ? ${$_} : $_ } @report; |
454 |
} |
455 |
|
456 |
##### Agregat functions ############## |
457 |
# agregat functions can be used within the -foot and -head |
458 |
# funtions. Before each call to either of these functions |
459 |
# a persistent @stor and a to 0 initialized $count variable |
460 |
# is made available with local |
461 |
|
462 |
sub rpsum ($) { |
463 |
my $cnt = $aggmem->{counter}++; |
464 |
my $arr = \$aggmem->{array}->[$cnt]; |
465 |
$$arr += $_[0]; |
466 |
return $$arr; |
467 |
} |
468 |
|
469 |
sub rpmin ($) { |
470 |
my $cnt = $aggmem->{counter}++; |
471 |
my $arr = \$aggmem->{array}->[$cnt]; |
472 |
$$arr= $_[0] |
473 |
if not defined $$arr |
474 |
or $$arr > $_[0]; |
475 |
return $$arr; |
476 |
} |
477 |
|
478 |
sub rpmax ($) { |
479 |
my $cnt = $aggmem->{counter}++; |
480 |
my $arr = \$aggmem->{array}->[$cnt]; |
481 |
$$arr= $_[0] |
482 |
if not defined $$arr |
483 |
or $$arr < $_[0]; |
484 |
return $$arr; |
485 |
} |
486 |
|
487 |
sub rpsmall ($) { |
488 |
my $cnt = $aggmem->{counter}++; |
489 |
my $arr = \$aggmem->{array}->[$cnt]; |
490 |
$$arr= $_[0] |
491 |
if not defined $$arr |
492 |
or $$arr gt $_[0]; |
493 |
return $$arr; |
494 |
} |
495 |
|
496 |
sub rpbig ($) { |
497 |
my $cnt = $aggmem->{counter}++; |
498 |
my $arr = \$aggmem->{array}->[$cnt]; |
499 |
$$arr= $_[0] |
500 |
if not defined $$arr |
501 |
or $$arr lt $_[0]; |
502 |
return $$arr; |
503 |
} |
504 |
|
505 |
sub rpcnt ($) { |
506 |
my $cnt = $aggmem->{counter}++; |
507 |
my $arr = \$aggmem->{array}->[$cnt]; |
508 |
$$arr++; |
509 |
return $$arr; |
510 |
} |
511 |
|
512 |
sub rpavg ($) { |
513 |
my $cnt = $aggmem->{counter}++; |
514 |
my $arr = \$aggmem->{array}->[$cnt]; |
515 |
$$arr->{sum} += $_[0]; |
516 |
$$arr->{cnt}++; |
517 |
return $$arr->{sum} / $$arr->{cnt}; |
518 |
} |
519 |
|
520 |
##### Internal Helpers ################# |
521 |
|
522 |
sub ask ($;$) { |
523 |
print STDERR $_[0]," "; |
524 |
system "stty -echo" |
525 |
if defined $_[1]; |
526 |
chomp(my $answer = <>); |
527 |
if (defined $_[1]){ |
528 |
system "stty echo"; |
529 |
print "\n"; |
530 |
} |
531 |
return $answer; |
532 |
} |
533 |
|
534 |
sub argcheck ($$$$) { |
535 |
my $func = shift; |
536 |
my $hash = shift; |
537 |
my $required = shift; |
538 |
my $optional = shift; |
539 |
foreach my $arg (@{$required}) { |
540 |
croak "$func expected $arg argument" |
541 |
unless exists $hash->{$arg}; |
542 |
} |
543 |
foreach my $arg (keys %{$hash}) { |
544 |
croak "$func does not support $arg arguments" |
545 |
unless grep /^$arg$/, @{$required}, @{$optional}; |
546 |
} |
547 |
} |
548 |
|
549 |
sub autoself (@){ |
550 |
return @_ if |
551 |
ref($_[0]) eq 'DBIx::PearlReports'; |
552 |
return \$DefaultSelf, @_; |
553 |
} |
554 |
|
555 |
1; |