[Bio] / Sprout / CustomAttributes.pm Repository:
ViewVC logotype

Diff of /Sprout/CustomAttributes.pm

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

revision 1.38, Sat Oct 18 09:52:21 2008 UTC revision 1.40, Tue Dec 30 08:58:14 2008 UTC
# Line 2  Line 2 
2    
3  package CustomAttributes;  package CustomAttributes;
4    
     require Exporter;  
     use ERDB;  
     @ISA = qw(ERDB);  
5      use strict;      use strict;
6      use Tracer;      use Tracer;
     use ERDBLoad;  
7      use Stats;      use Stats;
8      use Time::HiRes qw(time);      use Time::HiRes qw(time);
9      use FIGRules;      use FIGRules;
10        use base qw(ERDB);
11    
12  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
13    
# Line 154  Line 151 
151    
152  Name of the current user. This will appear in the attribute log.  Name of the current user. This will appear in the attribute log.
153    
154    =item dbd
155    
156    Filename for the DBD. If unspecified, the default DBD is used.
157    
158  =back  =back
159    
160  =cut  =cut
# Line 168  Line 169 
169                              $FIG_Config::attrPort, $FIG_Config::attrHost,                              $FIG_Config::attrPort, $FIG_Config::attrHost,
170                              $FIG_Config::attrSock);                              $FIG_Config::attrSock);
171      # Create the ERDB object.      # Create the ERDB object.
172      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = ($options{dbd} ? $options{dbd} : $FIG_Config::attrDBD);
173      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
174      # Store the splitter value.      # Store the splitter value.
175      $retVal->{splitter} = $options{splitter} || '::';      $retVal->{splitter} = $options{splitter} || '::';
# Line 222  Line 223 
223      if (! $table) {      if (! $table) {
224          $table = $self->{defaultRel};          $table = $self->{defaultRel};
225      }      }
     # Get the data type hash.  
     my %types = ERDB::GetDataTypes();  
226      # Validate the initial input values.      # Validate the initial input values.
227      if ($attributeName =~ /$self->{splitter}/) {      if ($attributeName =~ /$self->{splitter}/) {
228          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
# Line 1100  Line 1099 
1099          # then we can create SQL filtering for it. If any of the values are specified          # then we can create SQL filtering for it. If any of the values are specified
1100          # as a regular expression, however, that's more complicated, because          # as a regular expression, however, that's more complicated, because
1101          # we need to read every value to verify a match.          # we need to read every value to verify a match.
1102          if (@values > 0) {          if (@values > 0 && defined $values[0]) {
1103              # Get the first value and put its alternatives in an array.              # Get the first value and put its alternatives in an array.
1104              my $valueParm = $values[0];              my $valueParm = $values[0];
1105              my @valueList;              my @valueList;
# Line 1142  Line 1141 
1141          if ($key) {          if ($key) {
1142              # Here we have either a single key or a list. We convert both cases to a list.              # Here we have either a single key or a list. We convert both cases to a list.
1143              my $keyList = (ref $key ne 'ARRAY' ? [$key] : $key);              my $keyList = (ref $key ne 'ARRAY' ? [$key] : $key);
1144                Trace("Reading key table.") if T(3);
1145              # Get easy access to the key/table hash.              # Get easy access to the key/table hash.
1146              my $keyTableHash = $self->_KeyTable();              my $keyTableHash = $self->_KeyTable();
1147              # Loop through the keys, discovering tables.              # Loop through the keys, discovering tables.
1148              for my $keyChoice (@$keyList) {              for my $keyChoice (@$keyList) {
1149                  # Now we have to start thinking about the real key and the subkeys.                  # Now we have to start thinking about the real key and the subkeys.
1150                  my ($realKey, $subKey) = $self->_SplitKeyPattern($keyChoice);                  my ($realKey, $subKey) = $self->_SplitKeyPattern($keyChoice);
1151                    Trace("Checking $realKey against key table.") if T(3);
1152                  # Find the matches for the real key in the key hash. For each of                  # Find the matches for the real key in the key hash. For each of
1153                  # these, we memorize the table name in the hash below.                  # these, we memorize the table name in the hash below.
1154                  my %tableNames = ();                  my %tableNames = ();
1155                  for my $keyInTable (keys %{$keyTableHash}) {                  for my $keyInTable (keys %{$keyTableHash}) {
1156                      if ($self->_CheckSQLPattern($realKey, $keyInTable)) {                      if (_CheckSQLPattern($realKey, $keyInTable)) {
1157                          $tableNames{$keyTableHash->{$key}} = 1;                          $tableNames{$keyTableHash->{$key}} = 1;
1158                      }                      }
1159                  }                  }
# Line 1867  Line 1868 
1868          my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];          my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
1869          # Now we format the values. These remain unchanged unless one of them is a URL.          # Now we format the values. These remain unchanged unless one of them is a URL.
1870          my $lastValue = scalar(@{$attrData}) - 1;          my $lastValue = scalar(@{$attrData}) - 1;
1871          push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];          push @columns, map { $_ =~ /^http:/ ? CGI::a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
1872          # Assemble the values into a table row.          # Assemble the values into a table row.
1873          push @html, $cgi->Tr($cgi->td(\@columns));          push @html, CGI::Tr(CGI::td(\@columns));
1874      }      }
1875      # Format the table in the return variable.      # Format the table in the return variable.
1876      my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);      my $retVal = CGI::table({ border => 2 }, CGI::Tr(CGI::th(['Object', 'Key', 'Values'])), @html);
1877      # Return it.      # Return it.
1878      return $retVal;      return $retVal;
1879  }  }
# Line 1913  Line 1914 
1914      my $retVal;      my $retVal;
1915      # Insure the key table hash is present.      # Insure the key table hash is present.
1916      if (! exists $self->{keyTables}) {      if (! exists $self->{keyTables}) {
1917            Trace("Creating key table.") if T(3);
1918          $self->{keyTables} = { map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],          $self->{keyTables} = { map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],
1919                                                  "AttributeKey(relationship-name) <> ?",                                                  "AttributeKey(relationship-name) <> ?",
1920                                                  [$self->{defaultRel}],                                                  [$self->{defaultRel}],
# Line 2012  Line 2014 
2014                  # Here we have a regular expression match.                  # Here we have a regular expression match.
2015                  my $section = $sections[$i];                  my $section = $sections[$i];
2016                  $matching = eval("\$section =~ $value");                  $matching = eval("\$section =~ $value");
2017                } elsif (! defined $value) {
2018                    # Wild card. Skip it.
2019              } else {              } else {
2020                  # Here we have a normal match.                  # Here we have a normal match.
2021                  Trace("SQL match used.") if T(4);                  Trace("SQL match used.") if T(4);
# Line 2269  Line 2273 
2273          # Here it's an exact match.          # Here it's an exact match.
2274          $retVal = ($pattern eq $value);          $retVal = ($pattern eq $value);
2275      }      }
2276        Trace("SQL pattern check: \"$value\" vs \"$pattern\" = $retVal.") if T(3);
2277      # Return the result.      # Return the result.
2278      return $retVal;      return $retVal;
2279  }  }

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.40

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3