1 |
# -*- cperl -*- |
# -*- cperl -*- |
2 |
package PAPO::DataSource; |
package PAPO::DataSource; |
3 |
use strict; |
use strict; |
4 |
use warnings; |
use warnings; |
5 |
|
use English; |
6 |
use Data::Dumper; |
use Data::Dumper; |
7 |
use Carp; |
use Carp; |
8 |
use lib $ENV{HOME} . '/public_perl'; |
use lib "$ENV{HOME}/public_perl"; |
9 |
use Zot; |
use Zot; |
10 |
|
use PAPO::Condition; |
11 |
|
|
12 |
|
|
13 |
=head1 NAME |
=head1 NAME |
14 |
|
|
15 |
PAPO::DataSource - Perl module for the generation of PAPO-flavoured GNUe datasources |
PAPO::DataSource - Perl class for the generation of PAPO-flavoured |
16 |
|
GNUe datasources |
17 |
|
|
18 |
=head1 SYNOPSIS |
=head1 SYNOPSIS |
19 |
|
|
20 |
use PAPO::DataSource '/path/to/PAPO-ER.zot'; |
use PAPO::DataSource; |
21 |
|
|
22 |
|
my $ds = PAPO::DataSource->new("/path/to/PAPO-ER.zot", |
23 |
|
name => "fooDataSource", |
24 |
|
cache => 1); |
25 |
|
$ds->query("client"); |
26 |
|
$ds->dated_join("client", "own_document"); |
27 |
|
print $ds->datasource; |
28 |
|
|
29 |
=head1 DESCRIPTION |
=head1 DESCRIPTION |
30 |
|
|
31 |
Calculating GNUe datasources for slighly complex databases, such as |
Calculating GNUe datasources for slighly complex databases, such as |
32 |
the one used for PAPO, is a daunting task. The object of this module |
the one used for PAPO, is a daunting task. The object of this class |
33 |
is to automate said task away as much as possible. |
is to automate said task away as much as possible. |
34 |
|
|
35 |
On importing this module the parameter given is used to locate and |
=cut |
36 |
parse de zot definition of the database. Not providing this |
|
37 |
information is an error. |
|
38 |
|
=head1 METHODS |
39 |
|
|
40 |
|
=head2 new |
41 |
|
|
42 |
|
Returns a new PAPO::DataSource object. If called as a class method, |
43 |
|
requires a parameter (the location of the zot file). If called as an |
44 |
|
instance method, returns a new object that uses the same zot as the |
45 |
|
original instance. |
46 |
|
|
47 |
|
Any further arguments are interpreted as key/value pairs of the |
48 |
|
datasource. |
49 |
|
|
50 |
|
[ FIXME: explain better ] |
51 |
|
|
52 |
=cut |
=cut |
53 |
|
|
54 |
our $zot; |
sub new |
55 |
|
{ |
56 |
|
my $thing = shift; |
57 |
|
my $class = ref($thing) || $thing; |
58 |
|
my $self = bless {}, $class; |
59 |
|
|
60 |
|
unshift @_, $thing->zot |
61 |
|
if ref $thing; |
62 |
|
|
63 |
|
$self->init(@_); |
64 |
|
|
65 |
|
return $self; |
66 |
|
} |
67 |
|
|
68 |
|
|
69 |
|
|
70 |
# I am a hack. Please ignore me. |
=head2 init |
71 |
sub import |
|
72 |
|
Performs any required initialization. |
73 |
|
|
74 |
|
=cut |
75 |
|
|
76 |
|
sub init |
77 |
{ |
{ |
78 |
$zot = Zot->new($_[1])->parse; |
my $self = shift; |
79 |
|
my $zot = shift; |
80 |
|
|
81 |
|
$self->zot($zot); |
82 |
|
$self->{ATTRS} = {}; |
83 |
|
$self->{TABLES} = []; |
84 |
|
$self->{HISTORY_TABLES} = []; |
85 |
|
$self->condition(new PAPO::Condition); |
86 |
|
|
87 |
|
$self->attributes(@_); |
88 |
|
|
89 |
|
return $self; |
90 |
} |
} |
|
# Ok, you can stop ignoring me. |
|
91 |
|
|
92 |
|
|
93 |
|
=head2 attributes |
94 |
|
|
95 |
=head1 FUNCTIONS |
Sets/gets the current attributes hash. |
96 |
|
|
97 |
None of the functions below are exported. |
=cut |
98 |
|
|
99 |
=head2 simple |
sub attributes |
100 |
|
{ |
101 |
|
my $self = shift; |
102 |
|
my %attrs = (@_); |
103 |
|
|
104 |
Given the name of an object (e.g. C<client>), this function returns |
$self->{ATTRS}->{$_} = $attrs{$_} |
105 |
the datasource definition fragment that could be used for a form that |
foreach (keys %attrs); |
|
manipulates the object. |
|
106 |
|
|
107 |
If the object's table is transactional, the datasource joins against |
return $self->{ATTRS}; |
108 |
the transactional tables as well as the object hierarchy tables. |
} |
109 |
|
|
110 |
|
=head2 zot |
111 |
|
|
112 |
If the object's table is non-transactional, it doesn't. |
This method is slightly overloaded on its parameters. When called |
113 |
|
without any parameter, it simply returns the associated Zot. When |
114 |
|
called with a reference, this reference is assumed to be a Zot and |
115 |
|
used from then on. When called with a scalar, it is assumed to be the |
116 |
|
filename of a zot file, which is loaded, parsed, and used. |
117 |
|
|
118 |
Currently this checks at every level if the table is transactional |
=cut |
119 |
or not. Given the way we to things, it's probably not needed. Note |
|
120 |
the B<probably> bit. |
sub zot |
121 |
|
{ |
122 |
|
my $self = shift; |
123 |
|
my $zot = shift; |
124 |
|
|
125 |
|
if (defined $zot) |
126 |
|
{ |
127 |
|
if (ref $zot) |
128 |
|
{ |
129 |
|
$self->{ZOT} = $zot; |
130 |
|
} |
131 |
|
else |
132 |
|
{ |
133 |
|
my $file = $zot; |
134 |
|
my @path = split(":", $ENV{'ZOT_PATH'}||"."); |
135 |
|
|
136 |
|
foreach my $dir (reverse @path) |
137 |
|
{ |
138 |
|
$file = "$dir/$zot" if -f "$dir/$zot"; |
139 |
|
} |
140 |
|
|
141 |
|
$self->{ZOT} = Zot->new($file)->parse; |
142 |
|
} |
143 |
|
} |
144 |
|
|
145 |
|
return $self->{ZOT}; |
146 |
|
} |
147 |
|
|
148 |
|
|
149 |
|
=head2 condition |
150 |
|
|
151 |
|
This method provides a link to the associated PAPO::Condition object. |
152 |
|
|
153 |
=cut |
=cut |
154 |
|
|
155 |
sub simple |
sub condition |
156 |
{ |
{ |
157 |
|
my $self = shift; |
158 |
|
my $condition = shift; |
159 |
|
|
160 |
|
$self->{CONDITION} = $condition |
161 |
|
if defined $condition; |
162 |
|
|
163 |
|
return $self->{CONDITION}; |
164 |
|
} |
165 |
|
|
166 |
|
|
167 |
|
=head2 query |
168 |
|
|
169 |
|
Given the name of an object (e.g. C<client>), this method adds to the |
170 |
|
datasource definition the conditions that could be used for a form |
171 |
|
that manipulates the object, as well as the tables needed for the from |
172 |
|
clause. |
173 |
|
|
174 |
|
If the object's tables are transactional, the datasource joins against |
175 |
|
the transactional tables as well as the object hierarchy tables. |
176 |
|
|
177 |
|
If the object's table are non-transactional (instantaneous), it |
178 |
|
doesn't. |
179 |
|
|
180 |
|
=cut |
181 |
|
|
182 |
|
sub query |
183 |
|
{ |
184 |
|
my $self = shift; |
185 |
my $table = shift; |
my $table = shift; |
186 |
my @tables = ($table); |
my @tables = ($table); |
187 |
|
|
188 |
push @tables, $table |
push @tables, $table |
189 |
while ($table = $zot->table($table)->parent); |
while ($table = $self->zot->table($table)->parent); |
190 |
|
|
191 |
my $out = ''; |
$self->add_table($_) |
192 |
|
foreach (@tables); |
193 |
|
|
194 |
foreach $table (map $zot->table($tables[$_]), 0..$#tables-1) |
foreach $table (map $self->zot->table($tables[$_]), 0..$#tables-1) |
195 |
{ |
{ |
196 |
|
if ($table->has_style('history')) |
197 |
$out .= transactional_join($table) |
{ |
198 |
if ($table->has_style('history')); |
$self->condition->transactional_join($table); |
199 |
$out .= child_join($table); |
$self->add_table(sprintf "_%s_data", $table->name); |
200 |
|
$self->add_history_table(sprintf "_%s_data", $table->name); |
201 |
|
} |
202 |
|
$self->condition->child_join($table); |
203 |
} |
} |
204 |
|
|
205 |
$table = $zot->table($tables[-1]); |
$table = $self->zot->table($tables[-1]); |
206 |
|
|
207 |
$out .= transactional_join($table) |
if ($table->has_style('history')) |
208 |
if ($table->has_style('history')); |
{ |
209 |
|
$self->condition->transactional_join($table); |
210 |
|
$self->add_table(sprintf "_%s_data", $table->name); |
211 |
|
$self->add_history_table(sprintf "_%s_data", $table->name); |
212 |
|
} |
213 |
|
|
214 |
return $out; |
return $self; |
215 |
} |
} |
216 |
|
|
217 |
|
|
218 |
|
=head2 search |
|
=head2 query |
|
219 |
|
|
220 |
Given the name of an object (e.g. C<client>), this function returns |
Given the name of an object (e.g. C<client>), this function returns |
221 |
the datasource definition fragment that could be used for a form that |
the datasource definition fragment that could be used for a form that |
227 |
|
|
228 |
=cut |
=cut |
229 |
|
|
230 |
sub query |
sub search |
231 |
{ |
{ |
232 |
|
my $self = shift; |
233 |
my $table = shift; |
my $table = shift; |
234 |
my @tables = ($table); |
my @tables = ($table); |
235 |
|
|
236 |
push @tables, $table |
push @tables, $table |
237 |
while ($table = $zot->table($table)->parent); |
while ($table = $self->zot->table($table)->parent); |
238 |
|
|
239 |
my $out = ''; |
foreach $table (map $self->zot->table($tables[$_]), 0..$#tables-1) |
|
|
|
|
foreach $table (map $zot->table($tables[$_]), 0..$#tables-1) |
|
240 |
{ |
{ |
241 |
|
if ($table->has_style('history')) |
242 |
$out .= transactional_join($table) |
{ |
243 |
if ($table->has_style('history')); |
$self->condition->transactional_child_join($table); |
244 |
$out .= child_join($table); |
$self->add_table(sprintf "_%s_data", $table->name); |
245 |
|
} |
246 |
|
else { |
247 |
|
$self->condition->child_join($table); |
248 |
|
$self->add_table($table->name); |
249 |
|
} |
250 |
} |
} |
251 |
|
|
252 |
$table = $zot->table($tables[-1]); |
$table = $self->zot->table($tables[-1]); |
253 |
|
|
254 |
$out .= transactional_join($table) |
if ($table->has_style('history')) |
255 |
if ($table->has_style('history')); |
{ |
256 |
|
$self->add_table(sprintf "_%s_data", $table->name); |
257 |
|
} |
258 |
|
else |
259 |
|
{ |
260 |
|
$self->add_table($table->name); |
261 |
|
} |
262 |
|
|
263 |
return $out; |
return $self; |
264 |
} |
} |
265 |
|
|
266 |
|
|
267 |
=head2 dated |
=head2 dated |
268 |
|
|
269 |
Given the name of two objects (e.g. C<own_document> and |
Given the name of two objects (e.g. C<own_document> and |
271 |
fragment that could be used to join the two objects based on their |
fragment that could be used to join the two objects based on their |
272 |
dates. |
dates. |
273 |
|
|
274 |
Both objects must be either transactional or have an attribute 'date'; |
Both objects must be either transactional or have an attribute 'date' |
275 |
this is true of all joins of this kind you might want to do in PAPO |
(or the optional third parameter); this is true of all joins of this |
276 |
(either an object is transactional, or it is a dated snapshot). |
kind you might want to do in PAPO (either an object is transactional, |
277 |
|
or it is a dated snapshot). |
278 |
|
|
279 |
If you join two transactional objects, the resulting fragment will |
If you join two transactional objects, the resulting fragment will |
280 |
demand the second one be active for the whole life of the first one. |
demand the second one be active for the whole life of the first one. |
283 |
|
|
284 |
You can also call it with two Zot::Tables, instead. |
You can also call it with two Zot::Tables, instead. |
285 |
|
|
286 |
|
This keeps track of the tables used, but not the 'history_tables'. Is |
287 |
|
this a bug? |
288 |
|
|
289 |
=cut |
=cut |
290 |
|
|
291 |
sub dated |
sub dated |
292 |
{ |
{ |
293 |
my $table_a = ref $_[0] ? $_[0] : $zot->table($_[0]); |
my $self = shift; |
294 |
my $table_b = ref $_[1] ? $_[1] : $zot->table($_[1]); |
my $table_a = shift; |
295 |
my $out = ''; |
my $table_b = shift; |
296 |
|
my $date = shift || 'date'; |
297 |
|
|
298 |
|
$table_a = $self->zot->table($table_a) |
299 |
|
unless ref $table_a; |
300 |
|
$table_b = $self->zot->table($table_b) |
301 |
|
unless ref $table_b; |
302 |
|
|
303 |
my $hist_a = $table_a->has_style('history'); |
my $hist_a = $table_a->has_style('history'); |
304 |
my $hist_b = $table_b->has_style('history'); |
my $hist_b = $table_b->has_style('history'); |
305 |
|
|
306 |
if (not ( $hist_a or $hist_b) ) |
if (not ( $hist_a or $hist_b) ) |
307 |
{ |
{ |
308 |
$out = sprintf(<<EOF, |
|
309 |
<!-- pega %s con %s por fecha --> |
$self->condition->simple($table_a, $table_b, |
310 |
<eq> |
$table_a => $date, |
311 |
<cfield name="%s.date"/> |
$table_b => $date); |
312 |
<cfield name="%s.date"/> |
$self->add_table($table_a->name); |
313 |
</eq> |
$self->add_table($table_b->name); |
|
EOF |
|
|
$table_a->name, $table_b->name, |
|
|
$table_a->name, $table_b->name ); |
|
314 |
} |
} |
315 |
elsif ($hist_a and not $hist_b) |
elsif ($hist_a and not $hist_b) |
316 |
{ |
{ |
317 |
$out = sprintf(<<EOF, |
$self->condition->raw(<<EOF, |
318 |
<!-- pega %s con %s por fecha --> |
<!-- pega %s con %s por fecha --> |
319 |
<and> |
<and> |
320 |
<le> |
<le> |
321 |
<cfield name="_%s_data._start_t"/> |
<cfield name="_%s_data._start_t"/> |
322 |
<cfield name="%s.date"/> |
<cfield name="%s.%s"/> |
323 |
</le> |
</le> |
324 |
<or> |
<or> |
325 |
<null> |
<null> |
326 |
<cfield name="_%s_data._end_t"/> |
<cfield name="_%s_data._end_t"/> |
327 |
</null> |
</null> |
328 |
<le> |
<le> |
329 |
<cfield name="%s.date"/> |
<cfield name="%s.%s"/> |
330 |
<cfield name="_%s_data._end_t"/> |
<cfield name="_%s_data._end_t"/> |
331 |
</le> |
</le> |
332 |
</or> |
</or> |
333 |
</and> |
</and> |
334 |
EOF |
EOF |
335 |
$table_a->name, $table_b->name, |
$table_a, $table_b, |
336 |
$table_a->name, $table_b->name, |
$table_a, $table_b, $date, |
337 |
$table_b->name, |
$table_a, |
338 |
$table_b->name, $table_a->name ); |
$table_b, $date, $table_a ); |
339 |
|
|
340 |
|
$self->add_table(sprintf "_%s_data", $table_a->name); |
341 |
|
$self->add_table($table_b->name); |
342 |
} |
} |
343 |
elsif ($hist_b and not $hist_a) |
elsif ($hist_b and not $hist_a) |
344 |
{ |
{ |
345 |
$out = dated($table_b, $table_a); |
$self->dated($table_b, $table_a); |
346 |
} |
} |
347 |
else |
else |
348 |
{ |
{ |
349 |
$out = sprintf(<<EOF, |
$self->condition->raw(<<EOF, |
350 |
<!-- pega %s con %s por fecha --> |
<!-- pega %s con %s por fecha --> |
351 |
<and> |
<and> |
352 |
<le> |
<le> |
364 |
</or> |
</or> |
365 |
</and> |
</and> |
366 |
EOF |
EOF |
367 |
$table_a->name, $table_b->name, |
$table_a, $table_b, |
368 |
$table_b->name, $table_a->name, |
$table_b, $table_a, |
369 |
$table_b->name, |
$table_b, |
370 |
$table_a->name, $table_b->name ); |
$table_a, $table_b ); |
371 |
|
|
372 |
|
$self->add_table(sprintf "_%s_data", $table_a->name); |
373 |
|
$self->add_table(sprintf "_%s_data", $table_b->name); |
374 |
} |
} |
375 |
|
|
376 |
return $out; |
return $self; |
377 |
} |
} |
378 |
|
|
379 |
|
|
380 |
|
|
381 |
=head2 transactional_join |
sub datasource |
382 |
|
{ |
383 |
|
my $self = shift; |
384 |
|
|
385 |
|
my %h = %{$self->attributes}; |
386 |
|
my $ds = ' <datasource'; |
387 |
|
|
388 |
|
$ds .= " $_=\"$h{$_}\"" |
389 |
|
foreach (keys %h); |
390 |
|
|
391 |
|
$ds .= ' tables="' . join(',', $self->tables) . '"' |
392 |
|
if ($self->tables); |
393 |
|
|
394 |
Given a Zot::Table object this returns the GCondition fragment that |
$ds .= ' historytable="' . join(',', $self->history_tables) . '"' |
395 |
joins the table with its transactional table. |
if ($self->history_tables); |
396 |
|
|
397 |
|
$ds .= ">\n"; |
398 |
|
|
399 |
|
if ($self->conditions) |
400 |
|
{ |
401 |
|
$ds .= " <condition>\n"; |
402 |
|
$ds .= " <and>\n"; |
403 |
|
$ds .= $self->conditions; |
404 |
|
$ds .= " </and>\n"; |
405 |
|
$ds .= " </condition>\n"; |
406 |
|
} |
407 |
|
|
408 |
|
$ds .= " </datasource>\n"; |
409 |
|
|
410 |
|
$ds; |
411 |
|
} |
412 |
|
|
413 |
|
|
414 |
|
=head2 conditions |
415 |
|
|
416 |
|
Returns the content of the PAPO::Condition object. |
417 |
|
|
418 |
=cut |
=cut |
419 |
|
|
420 |
sub transactional_join |
sub conditions { $_[0]->condition->dump } |
421 |
|
|
422 |
|
|
423 |
|
=head2 add_table |
424 |
|
|
425 |
|
This method returns the current tables associated with the object, |
426 |
|
previously adding the table that might be passed as a parameter. |
427 |
|
|
428 |
|
=cut |
429 |
|
|
430 |
|
sub add_table |
431 |
{ |
{ |
432 |
|
my $self = shift; |
433 |
my $table = shift; |
my $table = shift; |
434 |
|
|
435 |
sprintf( <<EOF, |
push @{$self->{TABLES}}, $table |
436 |
<!-- pega %s con su _table --> |
if defined $table; |
437 |
<eq> |
|
438 |
<cfield name="%s.id"/> |
return @{$self->{TABLES}}; |
439 |
<cfield name="_%s_data._table"/> |
} |
440 |
</eq> |
|
441 |
EOF |
=head2 tables |
442 |
$table->name, $table->name, $table->name ); |
|
443 |
|
Returns a uniqified list of the tables associated with the datasource, |
444 |
|
in an order that tries to be easy to follow. Suitable for table="" |
445 |
|
stuff. |
446 |
|
|
447 |
|
=cut |
448 |
|
|
449 |
|
|
450 |
|
sub tables |
451 |
|
{ |
452 |
|
my $self = shift; |
453 |
|
my %idx = (); |
454 |
|
my @tables = (); |
455 |
|
|
456 |
|
foreach (@{$self->{TABLES}}) { |
457 |
|
push(@tables, $_), |
458 |
|
$idx{$_}++ |
459 |
|
unless $idx{$_}; |
460 |
|
} |
461 |
|
|
462 |
|
return @tables; |
463 |
} |
} |
464 |
|
|
465 |
|
=head2 add_history_table |
466 |
|
|
467 |
|
This method returns the current history_tables associated with the |
468 |
|
object, previously adding the history_table that might be passed as a |
469 |
|
parameter. |
470 |
|
|
471 |
|
=cut |
472 |
|
|
473 |
|
sub add_history_table |
474 |
|
{ |
475 |
|
my $self = shift; |
476 |
|
my $history_table = shift; |
477 |
|
|
478 |
=head2 child_join |
push @{$self->{HISTORY_TABLES}}, $history_table |
479 |
|
if defined $history_table; |
480 |
|
|
481 |
Given a Zot::Table object this returns the GCondition fragment that |
return @{$self->{HISTORY_TABLES}}; |
482 |
joins the table with its parent. |
} |
483 |
|
|
484 |
|
=head2 history_tables |
485 |
|
|
486 |
|
Returns a uniqified list of the history_tables associated with the |
487 |
|
datasource, in an order that tries to be easy to follow. Suitable for |
488 |
|
historytable="" stuff. |
489 |
|
|
490 |
=cut |
=cut |
491 |
|
|
492 |
sub child_join |
|
493 |
|
sub history_tables |
494 |
{ |
{ |
495 |
my $table = shift; |
my $self = shift; |
496 |
|
my %idx = (); |
497 |
|
my @history_tables = (); |
498 |
|
|
499 |
|
foreach (@{$self->{HISTORY_TABLES}}) { |
500 |
|
push(@history_tables, $_), |
501 |
|
$idx{$_}++ |
502 |
|
unless $idx{$_}; |
503 |
|
} |
504 |
|
|
505 |
sprintf( <<EOF, |
return @history_tables; |
|
<!-- pega %s con su %s --> |
|
|
<eq> |
|
|
<cfield name="%s.%s"/> |
|
|
<cfield name="%s.id"/> |
|
|
</eq> |
|
|
EOF |
|
|
$table->name, $table->parent, |
|
|
sprintf($table->has_style('history') ? "%s_data" : "%s", |
|
|
$table->name), $table->parent, |
|
|
$table->parent); |
|
506 |
} |
} |
507 |
|
|
508 |
|
=head1 ENVIRONMENT VARIABLES |
509 |
|
|
510 |
|
C<ZOT_PATH> is the search path for zot files. |
511 |
|
|
512 |
=head1 SEE ALSO |
=head1 SEE ALSO |
513 |
|
|
514 |
L<Zot> |
L<Zot>, L<PAPO::Condition> |
515 |
|
|
516 |
=head1 AUTHOR |
=head1 AUTHOR |
517 |
|
|
530 |
|
|
531 |
=head1 BUGS |
=head1 BUGS |
532 |
|
|
533 |
None. Really. |
None. Really. Other than... well, you'll find it soon enough. |
534 |
|
|
535 |
=cut |
=cut |
536 |
|
|