1 |
#!/usr/bin/perl |
#!/usr/bin/perl |
2 |
|
|
3 |
|
# this sucks slightly, due to chuminess with Zot, especially wrt |
4 |
|
# history. Ideas on how to fix that would be greatly appreciated. |
5 |
|
|
6 |
use warnings; |
use warnings; |
7 |
use strict; |
use strict; |
8 |
use AppConfig qw(:expand :argcount); |
use AppConfig qw(:expand :argcount); |
9 |
use Data::Dumper; |
use Data::Dumper; |
10 |
use zot; |
use lib "$ENV{HOME}/public_perl/"; |
11 |
|
use Zot; |
12 |
|
|
13 |
|
our $DEFAULT_WIDTH = 16; |
14 |
|
|
15 |
sub validate_file |
sub validate_file |
16 |
{ |
{ |
22 |
|
|
23 |
sub parent_condition |
sub parent_condition |
24 |
{ |
{ |
25 |
my $from = shift; |
my $zot = shift; |
26 |
my $h = shift; |
my $table = shift; |
|
my $condition = qq'<!-- pega %s con su padre (%s) -->\n' |
|
|
. qq'<eq>\n <cfield name="%s.id"/>\n <cfield name="%s.%s"/>\n</eq>'; |
|
|
my $parent = $h->{'PARENT'}; |
|
|
my $rel = ''; |
|
27 |
|
|
28 |
my $real_from = (exists($h->{'__HISTORY__'})) ? "_${from}_data" : $from; |
my $parent = $table->parent; |
29 |
|
return unless $parent; |
30 |
|
my $condition = ' |
31 |
|
<!-- pega %s con su padre (%s) --> |
32 |
|
<eq> |
33 |
|
<cfield name="%s.id"/> |
34 |
|
<cfield name="%s.%s"/> |
35 |
|
</eq>'; |
36 |
|
|
37 |
foreach (keys %{ $h->{'REL'} }) |
my ($rel) = grep $_ eq $parent, $table->rels; |
|
{ |
|
|
if ($h->{'REL'}{$_} eq $parent) |
|
|
{ |
|
|
$rel = $_; |
|
|
} |
|
|
} |
|
38 |
|
|
39 |
sprintf "$condition\n", $from, $rel, $h->{'REL'}{$rel}, $real_from, $rel; |
return sprintf( $condition . ($table->has_style('history')) ? "_%s_data" : "%s", |
40 |
|
$table->name, $rel, $table->rel($rel), $table->name, $rel ); |
41 |
} |
} |
42 |
|
|
43 |
|
|
44 |
sub history_conditions |
sub history_conditions |
45 |
{ |
{ |
46 |
|
my $zot = shift; |
47 |
my $table = shift; |
my $table = shift; |
48 |
|
$table = $table->name; |
49 |
|
|
50 |
qq'<!-- pega $table con su _data -->\n<eq>\n <cfield name="${table}.id"/>\n <cfield name="_${table}_data._table"/>\n</eq>\n' |
return qq' |
51 |
. qq'<!-- descarta todo $table muerto -->\n<null>\n <cfield name="_${table}_data._end_t"/>\n</null>\n'; |
<!-- pega $table con su _data --> |
52 |
|
<eq> |
53 |
|
<cfield name="${table}.id"/> |
54 |
|
<cfield name="_${table}_data._table"/> |
55 |
|
</eq> |
56 |
|
<!-- descarta todo $table muerto --> |
57 |
|
<null> |
58 |
|
<cfield name="_${table}_data._end_t"/> |
59 |
|
</null>' |
60 |
} |
} |
61 |
|
|
62 |
sub repeat |
sub repeat |
63 |
{ |
{ |
64 |
my $chunk = shift; |
my $chunk = shift; |
65 |
my $res = shift; |
my $res = shift; |
66 |
my $struct = shift; |
my $zot = shift; |
67 |
my $r = ''; |
my $r = ''; |
68 |
my $n = 0; |
my $n = 0; |
69 |
my $width = 16; |
my $width = $DEFAULT_WIDTH; |
70 |
# print STDERR Dumper $struct; |
# print STDERR Dumper $struct; |
71 |
foreach (grep /^LABEL_/, keys %$res) |
foreach (grep /^LABEL_/, keys %$res) |
72 |
{ |
{ |
79 |
my ($table, $field) = $res->{$_} =~ /^(.*)\.(.*)$/; |
my ($table, $field) = $res->{$_} =~ /^(.*)\.(.*)$/; |
80 |
$table =~ s/^_(.*)_data$/$1/; |
$table =~ s/^_(.*)_data$/$1/; |
81 |
|
|
82 |
if ($struct->{$table}{'ATTR'}{$field} =~ /(\d+)/) |
if ($zot->table($table)->attr($field) =~ /(\d+)/) |
83 |
{ |
{ |
84 |
$width = $1 + 1; |
$width = $1 + 1; |
85 |
} |
} |
104 |
EXPAND => EXPAND_ALL |
EXPAND => EXPAND_ALL |
105 |
}}, |
}}, |
106 |
'database', |
'database', |
107 |
'table' => { ARGCOUNT => ARGCOUNT_LIST }, |
'sorter', |
108 |
|
'table', |
109 |
'form', |
'form', |
110 |
'zotfile' => { VALIDATE => \&validate_file }, |
'zotfile' => { VALIDATE => \&validate_file }, |
111 |
'skeleton' => { VALIDATE => \&validate_file }, |
'skeleton' => { VALIDATE => \&validate_file }, |
116 |
|
|
117 |
$config->file($ARGV[0]); |
$config->file($ARGV[0]); |
118 |
|
|
119 |
my (%s, $skel, @tables, $table, @histables, @conditions); |
my ($zot, $skel, @tables, @histables, @conditions); |
120 |
|
|
121 |
open ZOTFILE, $config->zotfile() |
open SKELETON, $config->skeleton |
|
or die("Unable to open zotfile " . $config->zotfile() ); |
|
|
open SKELETON, $config->skeleton() |
|
122 |
or die("Unable to open skeleton " . $config->skeleton() ); |
or die("Unable to open skeleton " . $config->skeleton() ); |
123 |
|
|
124 |
%s = zot::parse(<ZOTFILE>); |
$zot = Zot->new($config->zotfile); |
125 |
|
$zot->parse(); |
126 |
|
|
127 |
undef $/; |
undef $/; |
128 |
$skel = <SKELETON>; |
$skel = <SKELETON>; |
129 |
|
|
130 |
@tables = @{$config->table()}; |
@tables = ($zot->lineage($config->table)); |
|
$table = $tables[0]; |
|
|
while (exists($s{$table}{'PARENT'})) |
|
|
{ |
|
|
my $parent = $s{$table}{'PARENT'}; |
|
|
push @tables, $parent; |
|
|
push @conditions, parent_condition($table, $s{$table}); |
|
|
$table = $parent; |
|
|
} |
|
131 |
|
|
132 |
foreach (@tables) |
foreach (@tables) |
133 |
{ |
{ |
134 |
push( @histables, "_${_}_data" ) |
push( @histables, sprintf("_%s_data", $_->name) ) |
135 |
if $s{$_}{'__HISTORY__'}; |
if $_->has_style('history'); |
136 |
push @conditions, history_conditions($_); |
push @conditions, parent_condition($zot, $_); |
137 |
|
push @conditions, history_conditions($zot, $_); |
138 |
} |
} |
139 |
|
|
140 |
my %results = ( 'TABLES' => join( ', ', @tables, @histables ), |
my %results = ( 'TABLES' => join( ', ', map( $_->name, @tables ), @histables ), |
141 |
'HISTORYTABLES' => join( ', ', @histables ), |
'HISTORYTABLES' => join( ', ', @histables ), |
142 |
'CONDITIONS' => "@conditions" ); |
'CONDITIONS' => "@conditions" ); |
143 |
|
|
144 |
$results{uc $_} = $config->get($_) |
$results{uc $_} = $config->get($_) |
145 |
foreach qw(form database); |
foreach qw(form database sorter); |
146 |
|
|
147 |
foreach my $class qw(page box label) |
foreach my $class qw(page box label) |
148 |
{ |
{ |
152 |
|
|
153 |
foreach my $table (reverse @tables) |
foreach my $table (reverse @tables) |
154 |
{ |
{ |
155 |
foreach my $field (keys %{ $s{$table}{'ATTR'} }) |
my $table_name = $table->name; |
156 |
|
foreach my $field ($table->attrs) |
157 |
{ |
{ |
158 |
my $name = "FIELD_\U$field"; |
my $field_name = "FIELD_\U$field"; |
159 |
|
|
160 |
if ($s{$table}{'__HISTORY__'} && $field ne 'id') |
if ($table->has_style('history') && $field_name ne 'id') |
161 |
{ |
{ |
162 |
$results{$name} = "_${table}_data.$field"; |
$results{$field_name} = "_${table_name}_data.$field"; |
163 |
} |
} |
164 |
else |
else |
165 |
{ |
{ |
166 |
$results{$name} = "$table.$field"; |
$results{$field_name} = "$table_name.$field"; |
167 |
} |
} |
168 |
} |
} |
169 |
} |
} |
173 |
|
|
174 |
$results{'FIELD_ID'} ||= "$tables[0].id"; |
$results{'FIELD_ID'} ||= "$tables[0].id"; |
175 |
|
|
176 |
$skel =~ s/\@\@DO\@\@(.*?)\@\@DONE\@\@/repeat($1, \%results, \%s)/ges; |
$skel =~ s/\@\@DO\@\@(.*?)\@\@DONE\@\@/repeat($1, \%results, $zot)/ges; |
177 |
|
|
178 |
$skel =~ s/\@\_([A-Z_]+)\_\@/$results{$1}||"XXXX UNDEFINED ($1) XXXX"/ge; |
$skel =~ s/\@\_([A-Z_]+)\_\@/$results{$1}||"XXXX UNDEFINED ($1) XXXX"/ge; |
179 |
|
|