/[papo]/papo/zot/zot2gfd.pl
ViewVC logotype

Diff of /papo/zot/zot2gfd.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by jlenton, Thu Nov 14 22:36:11 2002 UTC revision 1.3 by jlenton, Wed Nov 27 02:30:40 2002 UTC
# Line 1  Line 1 
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  {  {
# Line 15  sub validate_file Line 22  sub validate_file
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      {      {
# Line 64  sub repeat Line 79  sub repeat
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          }          }
# Line 89  my $config = AppConfig->new({ CASE => 1, Line 104  my $config = AppConfig->new({ CASE => 1,
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 },
# Line 100  my $config = AppConfig->new({ CASE => 1, Line 116  my $config = AppConfig->new({ CASE => 1,
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  {  {
# Line 144  foreach my $class qw(page box label) Line 152  foreach my $class qw(page box label)
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  }  }
# Line 164  push @tables, @histables; Line 173  push @tables, @histables;
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    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26