[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.33, Tue Aug 12 06:06:02 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 1083  Line 1082 
1082  sub GetAttributes {  sub GetAttributes {
1083      # Get the parameters.      # Get the parameters.
1084      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1085        # Declare the return variable.
1086        my @retVal = ();
1087        # Insure we have at least some sort of filtering going on.
1088        if (! grep { defined $_ } $objectID, $key, @values) {
1089            Confess("No filters specified in GetAttributes call.");
1090        } else {
1091      # This hash will map value-table fields to patterns. We use it to build the      # This hash will map value-table fields to patterns. We use it to build the
1092      # SQL statement.      # SQL statement.
1093      my %data;      my %data;
# Line 1092  Line 1097 
1097      # in the normal way. If the user specifies a generic search or exact match for      # in the normal way. If the user specifies a generic search or exact match for
1098      # every alternative value (remember, the values may be specified as a list),      # every alternative value (remember, the values may be specified as a list),
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 a problem, because we need to read          # as a regular expression, however, that's more complicated, because
1101      # 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 1136  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 1161  Line 1168 
1168              }              }
1169          }          }
1170      }      }
     # Declare the return variable.  
     my @retVal = ();  
1171      # Now we loop through the tables of interest, performing queries.      # Now we loop through the tables of interest, performing queries.
1172      # Loop through the tables.      # Loop through the tables.
1173      for my $table (keys %tables) {      for my $table (keys %tables) {
# Line 1227  Line 1232 
1232                          # Here we have to select on both keys.                          # Here we have to select on both keys.
1233                          my ($subClause, $subValue) = _WherePart($table, 'subkey', $subKey);                          my ($subClause, $subValue) = _WherePart($table, 'subkey', $subKey);
1234                          push @pairFilters, "($realClause AND $subClause)";                          push @pairFilters, "($realClause AND $subClause)";
1235                          push @parms, $subValue;                              push @parms, $realValue, $subValue;
1236                      }                      }
1237                  }                  }
1238                  # Join the pair filters together to make a giant key filter.                  # Join the pair filters together to make a giant key filter.
# Line 1243  Line 1248 
1248              push @retVal, $self->_QueryResults($query, $table, @values);              push @retVal, $self->_QueryResults($query, $table, @values);
1249          }          }
1250      }      }
1251        }
1252      # The above loop ran the query for each necessary value table and merged the      # The above loop ran the query for each necessary value table and merged the
1253      # results into @retVal. Now we return the rows found.      # results into @retVal. Now we return the rows found.
1254      return @retVal;      return @retVal;
# Line 1862  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 1908  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 1979  Line 1986 
1986      my ($self, $query, $table, @values) = @_;      my ($self, $query, $table, @values) = @_;
1987      # Declare the return value.      # Declare the return value.
1988      my @retVal = ();      my @retVal = ();
1989        # We use this hash to check for duplicates.
1990        my %dupHash = ();
1991      # Get the number of value sections we have to match.      # Get the number of value sections we have to match.
1992      my $sectionCount = scalar(@values);      my $sectionCount = scalar(@values);
1993      # Loop through the assignments found.      # Loop through the assignments found.
# Line 2005  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);
2022                  $matching = _CheckSQLPattern($values[$i], $sections[$i]);                  $matching = _CheckSQLPattern($values[$i], $sections[$i]);
2023              }              }
2024          }          }
2025          # If we match, output this row to the return list.          # If we match, consider writing this row to the return list.
2026          if ($matching) {          if ($matching) {
2027                # Check for a duplicate.
2028                my $wholeThing = join($self->{splitter}, $id, $key, $valueString);
2029                if (! $dupHash{$wholeThing}) {
2030                    # It's okay, we're not a duplicate. Insure we don't duplicate this result.
2031                    $dupHash{$wholeThing} = 1;
2032              push @retVal, [$id, $key, @sections];              push @retVal, [$id, $key, @sections];
2033          }          }
2034      }      }
2035        }
2036      # Return the rows found.      # Return the rows found.
2037      return @retVal;      return @retVal;
2038  }  }
# Line 2201  Line 2218 
2218      # Copy the pattern into the return area.      # Copy the pattern into the return area.
2219      $escapedValue = $sqlPattern;      $escapedValue = $sqlPattern;
2220      # Check the pattern. Is it generic or exact?      # Check the pattern. Is it generic or exact?
2221      if ($sqlPattern =~ /%$/) {      if ($sqlPattern =~ /(.+)%$/) {
2222          # Yes, it is. We need a LIKE clause and we must escape the underscores          # Yes, it is. We need a LIKE clause and we must escape the underscores
2223          # and percents in the pattern.          # and percents in the pattern (except for the last one, of course).
2224            $escapedValue = $1;
2225          $escapedValue =~ s/(%|_)/\\$1/g;          $escapedValue =~ s/(%|_)/\\$1/g;
2226            $escapedValue .= "%";
2227          $sqlClause = "$tableName($fieldName) LIKE ?";          $sqlClause = "$tableName($fieldName) LIKE ?";
2228      } else {      } else {
2229          # No, it isn't. We use an equality clause.          # No, it isn't. We use an equality clause.
# Line 2254  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.33  
changed lines
  Added in v.1.40
MCS Webmaster
 ViewVC Help
Powered by ViewVC 1.0.3