perl/DBIx/PearlReports.pm

=pod

=head1 NAME

DBIx::PearlReports -- A Versatile Report Generator

=head1 SYNOPSIS

Using the SIMPLE mode

 use DBIx::PearlReports qw(:Simple);
 create (
    -datasource => 'dbi:Pg:dbname=database;host=hostname',
    -query => 'SELECT * FROM customers ORDER BY state, city;'
 );

or

 create (
    -datasource => 'dbi:Pg:dbname=database;host=hostname',
    -query => 'SELECT * FROM customers ORDER BY state, city WHERE name = ? AND age = ?',
    -param => ['Tobi',34],
 );

 group (
    -trigger => sub { $filed{state} },
    -head => sub { "State: $field{state}\n" },
    -foot => sub { "Average Age for $field{state}".rpavg($field{age}) }
 );

 group (
    -trigger => sub { $field{city} },
    -head => sub { "City: $field{city} (".rpcnt($field{name}.")\n" },
    -foot => sub { "Total Customers in Customers in ".
                   "$field{city}: ".rpcnt($field{name})."\n" }
 );

 body (
     -contents => sub { "$field{firstname} $field{lastname} $field{age}\n" }
 );

 print makereport;

PearlReports can also be used in an Object Oriented Context:

 #!/usr/sepp/bin/perl-5.8.0
 use lib qw( /usr/pack/postgresql-7.3.2-ds/lib/site_perl /usr/isgtc/lib/perl);
 use DBIx::PearlReports;
 $r = DBIx::PearlReports::create ( ... );
 $r->group( ... );
 $r->body( ... )
 print $r->makereport;


=head1 DESCRIPTION

B<PearlReports> is a system for pulling information from an SQL database and
produce Reports from this information. B<PearlReports> provides a very
flexible system for creating reports based on SQL queries

While it is sufficient to use the simple statements provided by
PearlReports to create your reports, the full power of perl is only a
keystroke away.

Creating a Report using the PearlReports involves writing a short perl
script which first loads the PearlReports module:

 #!/usr/bin/perl
 use DBIx::PearlReports qw(:SIMPLE);

Then you call the B<create> function to create a new report:

 create (
     -username  => 'myname',
     -datasource => 'dbi:Pg:dbname=customers',
     -query => 'SELECT * from customers ORDER by state,city'
 );

When creating a report you have to define username and password for
the database you want to access. Because different people may use the
report. If you do not mention either the B<-username> or B<-password>
arguments, the module will ask you to supply one at run time.

The B<-datasource> argument defines which
database this report is going to use. Check the DBI/DBD documentation
for the syntax apropriate for your Database. In the example above we
are accessing a PostgreSQL database called I<customers> which runs on
the local host.  The B<-query> argument of the create function defines
the data we want to use in our report.

A central element of PearlReports is the ability to work with groups of
records. In this example the report contains two nested groups. Note that
the data

must arive from the database in an order which is comatible with the
required groups. (Check the ORDER BY cause above).

 group
  ( -trigger => sub { $field{state} },
    -head => sub { "Customers from $field{state}\n" },
    -foot => sub { "Avg Age for $field{state} Customer:".
                    rpavg($field{age})."\n\n"  } );

 group
  ( -trigger => sub { $field{zip} },
    -head => sub { "Customers from $field{town}\n" },
    -foot => sub { "Min Age in $field{town}:".
                   rpmin($field{age})."\n" } );


Each group definition requires a trigger and either a header or a
footer or both. Each argument of the group definition is a little perl
function definition. The Trigger function gets called for each record
in the query. Whenever the value returned from the
function changes the group iterates. Each iteration of a group is
enclosed by the apropriate header and footer.

The B<$field{xxx}> variables refer to the columns of the query.
The footer and the header (!) can contain agregation functions
(rpmin, rpmax, rpbig, rpsmall, rpsum, rpavg). See the section below

Finally the actual data can get printed.

 body
  ( -contents => sub { "$field{firstname} $field{lastname} $field{age}\n" } );

The body function will get called for each row in the database and its
return value will be printed into the report.

When groups and body are set up you can create the actual report by
executing:

 print makereport;

When you want to make a new report using the existion database connection
for another report, you can reset it with the command

 reset;

=head2 METHODS

All functions provided by PearlReports expect named arguments.

=head3 create or new

Defines the data the report should be based on. This involves
configuring the parameters for accessing the database server as well
as defining the query string.

If you are working with the OO interface you can use b<new> instead
of create to be more in line with established naming conventions.

=over

=item -username

the username for the database. If this option is not set, PearlReports will
prompt for a username.

=item -password

the password. If this option is not supplied PearlReports will prompt for a
password.

=item -datasource

the DBI connect string. Check the DBI/DBD manpage for the syntax apropriate
for your database.

=item -handle

instead of the previous 3 arguments you can also give PearlReports an
existing database handle to use.

=item -query

A SELECT query

=item -param

If you use '?' placeholders in the query, you can supply contents for them
using the reference to an arry holding the relevant data.

=back


=head2 group

The 'salt' of most reports is that some grouping structure exists. The
records in the report get collected into groups of records which bear
some common feature. Each group can have a header and a footer.

=over

=item -trigger

Is a pointer to a anonymous function. The function gets called for
each row in the result of the query. Whenever the return value from
this function changes the group goes into its next iteration.  There
are other events which can cause a new iteration: A higher order group
goes into another iteration or the last record from the query has been
consumed.

=item -head and -foot

After each iteration, the anonymouse functions pointed to by the head
and foot options get executed. The return values from the functions
are used as header and footer for the material inside the group.

=back

=head3 body

The inner most 'group' of the report does have neither foot nor head,
it has just a body which gets printed for every row in the query result.

=over

=item -contents

Stores a pointer to an anonymous function which gets executed for each
record returned by the query.

=back

=head3 makereport

returns an array containing the report ...

=head3 reset

clears the group and body data from the report. This can be used to run a
second report of the same database connection without reconnecting.

=head2 AGGREGATE FUNCTIONS

=head3 rpsum

Builds the sum of all the values its argument takes during the
traversal of the records in the current group iteration.

=head3 rpmin, rpmax

Finds the min and max values in a group iteration.

=head3 rpsmall, rpbig

Finds the first and last value when sorting alphabetically.

=head3 rpcnt

Count the rows in the current group iteration.

=head3 rpavg

The same as above only that the average gets calculated.

=head2 HOW TO WRITE NEW AGGREGATE FUNCTIONS

If you want to write your own aggregat functions. Follow the examples
below. Note that the first two lines of each function are
mandatory. The structure you store in the $arr is up to you.

 use PearlReports qw(:MyAgg);

 sub mycnt ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr++
    return $$arr;
 }

 sub myavg ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr->{sum} += $_[0];
    $$arr->{cnt}++;
    return $$arr->{sum} / $$arr->{cnt};
 }

If you create cool aggregate functions please drop me a line.

=head1 HISTORY

 2002-06-12 to Initial ISGTC release
 2003-07-16 to Added -handle option
 2003-07-29 to Added -param option

=head1 AUTHOR

S<Tobias Oetiker E<lt>oetiker@ee.ethz.chE<gt>>

=head1 COPYRIGHT

(C) 2000 by ETH Zurich

=head1 LICENSE

This code is made available under the GNU General Public License
Version 2.0 or later (see www.gnu.org)

=cut

package DBIx::PearlReports;

use Carp;
use strict;
use DBI;
use vars qw(%field $VERSION @EXPORT %EXPORT_TAGS @ISA);  # it's a package global
require Exporter;
$VERSION=1.0;

@ISA = qw(Exporter);
@EXPORT = qw(%field rpmin rpmax rpsum rpcnt rpavg rpsmall rpbig);
%EXPORT_TAGS = ('Simple' => [qw(create group body makereport reset)],
                'MyAgg' => [qw($aggmem)]);

#prototypes
sub argcheck ($$$$);
sub autoself (@);
sub ask ($;$);

my $DefaultSelf;
#implementation

sub create {
    my %args = @_;
    my $self = {};
    bless $self;
    $DefaultSelf = $self; # set default for SIMPLE use
    if (not exists $args{-handle}){
            argcheck "create", \%args, [qw(-datasource -query)],[qw(-username -password -param)];
            $args{-username} = ask('Username:') unless defined $args{-username};
            $args{-password} = ask('password:',1) unless defined $args{-password};
    } else {
            argcheck "create", \%args, [qw(-handle -query)],[(-param)];
            $self->{dbh} = $args{-handle};
    }
    $self->{NEW} = \%args;
    return $self;
}

sub new {
    return create @_;
}

sub group {
    my ($self, %args) = autoself @_;
    argcheck "group", \%args, [qw(-trigger)],[qw(-head -foot)];
    $args{aggmem} = {}; # this will hold info from the groups aggmem calls
    push @{$self->{GROUPS}}, \%args;
}

sub body {
    my ($self, %args) = autoself @_;
    argcheck "body", \%args, [qw(-contents)],[];
    croak "there can be only one body in a report"
      if exists $self->{BODY}->{-contents};
    $self->{BODY}->{-contents} = $args{-contents};
}

# Global variable providing static, group local memmory 
# for all agregat functions.
my $aggmem;

# reset GROUPS and BODY asignement of report;

sub reset {
   my ($self, %args) = autoself @_;
   $self->{GROUPS} = [];
   $self->{BODY} = undef;
}

sub makereport {
    my ($self, %args) = autoself @_;
    # open the database and get the data
    if ( not defined $self->{dbh} ) {
            $self->{dbh} = DBI->connect( $self->{NEW}->{-datasource},
                                         $self->{NEW}->{-username},
                                         $self->{NEW}->{-password}
                                       ) or croak $DBI::errstr;
    }

    $self->{sth} = $self->{dbh}->prepare_cached($self->{NEW}->{-query})
      or croak $self->{dbh}->errstr;

    if ($self->{NEW}->{-param}){
      my @param = @{$self->{NEW}->{-param}};
      for(1..scalar(@param)){
        #count from 1 to number_of_parameters including.
        #sql parameters start at 1. 
        $self->{sth}->bind_param($_,shift @param);
      }
    }

    $self->{sth}->execute() or croak $self->{dbh}->errstr."\n\nQuery: $self->{NEW}->{-query}";

    my @report; #this array holds the report

    # loop through query response
    while (my $row = $self->{sth}->fetchrow_hashref) {
        %field = %$row;
        my $cascade;
        my @headstack;
        my @footstack;
        foreach my $group (@{$self->{GROUPS}}) {
            # $aggmem is the temporery storage are for all aggmem functions
            # called within the current group

            $aggmem = $group->{aggmem}; # asign aggmem pointer

            #evaluate current value of the trigger functions
            my $trigval = &{$group->{-trigger}};
            if (defined $cascade or not defined $group->{trigval}
                or $trigval ne $group->{trigval}){
                $group->{trigval} = $trigval;

                # if the trigger fired, fall through all the lower groups
                # they have to rotate too
                $cascade = 1;

                $aggmem->{array} = []; # clear aggmem storage

                unshift @footstack, $group->{footsave} 
                        if defined $group->{-foot};
                # OK, this is a bit of voodo. Because I want that you can use agregate
                # functions in the head section we store a pointer to a string
                # and push it into the report. For each record in the group this
                # string gets updated (through the pointer)
                my $string = "";                
                push @headstack, \$string;
                $group->{headref} = \$string;
            }
            $aggmem->{counter} = 0; # reset aggmem storage pointer
            ${$group->{headref}} = &{$group->{-head}} if exists $group->{-head};
            $group->{footsave} = &{$group->{-foot}} if exists $group->{-foot};
        }
        push @report, @footstack;
        push @report, @headstack;
        push @report, &{$self->{BODY}->{-contents}} if defined $self->{BODY};

    }
    my @footstack;
    foreach my $group (@{$self->{GROUPS}}) {
        unshift @footstack , $group->{footsave} 
                if defined $group->{-foot};
    } 
    push @report, @footstack;
    $self->{sth}->finish;
    # $self->{dbh}->disconnect;  
    # now we resolve all the -head pointers left in the report stack    
    # and we only ship values back which evaluated to a defined value
    return grep {defined $_} map {ref $_ eq 'SCALAR' ? ${$_} : $_ } @report;
}

##### Agregat functions ##############
# agregat functions can be used within the -foot and -head
# funtions. Before each call to either of these functions
# a persistent @stor and a to 0 initialized $count variable
# is made available with local

sub rpsum ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr += $_[0];
    return $$arr;
}

sub rpmin ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
   $$arr= $_[0]
      if not defined $$arr
        or $$arr > $_[0];
    return $$arr;
}

sub rpmax ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr= $_[0]
      if not defined $$arr
        or $$arr < $_[0];
    return $$arr;
}

sub rpsmall ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr= $_[0]
      if not defined $$arr
        or $$arr gt $_[0];
    return $$arr;
}

sub rpbig ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr= $_[0]
      if not defined $$arr
        or $$arr lt $_[0];
    return $$arr;
}

sub rpcnt ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr++;
    return $$arr;
}

sub rpavg ($) {
    my $cnt = $aggmem->{counter}++;
    my $arr = \$aggmem->{array}->[$cnt];
    $$arr->{sum} += $_[0];
    $$arr->{cnt}++;
    return $$arr->{sum} / $$arr->{cnt};
}

##### Internal Helpers #################

sub ask ($;$) {
    print STDERR $_[0]," ";
    system "stty -echo"
      if defined $_[1];
    chomp(my $answer = <>);
    if (defined $_[1]){
        system "stty echo";
        print "\n";
    }
    return $answer;
}

sub argcheck ($$$$) {
    my $func = shift;
    my $hash = shift;
    my $required = shift;
    my $optional = shift;
    foreach my $arg (@{$required}) {
        croak "$func expected $arg argument" 
          unless exists $hash->{$arg};
    }
    foreach my $arg (keys %{$hash}) {
        croak "$func does not support $arg arguments"
          unless grep /^$arg$/, @{$required}, @{$optional};
    }
}

sub autoself (@){
    return @_ if
      ref($_[0]) eq 'DBIx::PearlReports';
    return \$DefaultSelf, @_;
}

1;
1	dpavlin	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;