9 |
use DBObject; |
use DBObject; |
10 |
use Stats; |
use Stats; |
11 |
use Time::HiRes qw(gettimeofday); |
use Time::HiRes qw(gettimeofday); |
12 |
|
use Digest::MD5 qw(md5_base64); |
13 |
use FIG; |
use FIG; |
14 |
|
use CGI; |
15 |
|
|
16 |
=head1 Entity-Relationship Database Package |
=head1 Entity-Relationship Database Package |
17 |
|
|
60 |
B<start-position>, which indicates where in the contig that the sequence begins. This attribute |
B<start-position>, which indicates where in the contig that the sequence begins. This attribute |
61 |
is implemented as the C<start_position> field in the C<IsMadeUpOf> relation. |
is implemented as the C<start_position> field in the C<IsMadeUpOf> relation. |
62 |
|
|
63 |
The database itself is described by an XML file using the F<ERDatabase.xsd> schema. In addition to |
The database itself is described by an XML file. In addition to all the data required to define |
64 |
all the data required to define the entities, relationships, and attributes, the schema provides |
the entities, relationships, and attributes, the schema provides space for notes describing |
65 |
space for notes describing the data and what it means. These notes are used by L</ShowMetaData> |
the data and what it means. These notes are used by L</ShowMetaData> to generate documentation |
66 |
to generate documentation for the database. |
for the database. |
67 |
|
|
68 |
|
Special support is provided for text searching. An entity field can be marked as <em>searchable</em>, |
69 |
|
in which case it will be used to generate a text search index in which the user searches for words |
70 |
|
in the field instead of a particular field value. |
71 |
|
|
72 |
Finally, every entity and relationship object has a flag indicating if it is new or old. The object |
Finally, every entity and relationship object has a flag indicating if it is new or old. The object |
73 |
is considered I<old> if it was loaded by the L</LoadTables> method. It is considered I<new> if it |
is considered I<old> if it was loaded by the L</LoadTables> method. It is considered I<new> if it |
74 |
was inserted by the L</InsertObject> method. |
was inserted by the L</InsertObject> method. |
75 |
|
|
|
To facilitate testing, the ERDB module supports automatic generation of test data. This process |
|
|
is described in the L</GenerateEntity> and L</GenerateConnection> methods, though it is not yet |
|
|
fully implemented. |
|
|
|
|
76 |
=head2 XML Database Description |
=head2 XML Database Description |
77 |
|
|
78 |
=head3 Data Types |
=head3 Data Types |
92 |
|
|
93 |
32-bit signed integer |
32-bit signed integer |
94 |
|
|
95 |
|
=item counter |
96 |
|
|
97 |
|
32-bit unsigned integer |
98 |
|
|
99 |
=item date |
=item date |
100 |
|
|
101 |
64-bit unsigned integer, representing a PERL date/time value |
64-bit unsigned integer, representing a PERL date/time value |
115 |
compatability with certain database packages), but the only values supported are |
compatability with certain database packages), but the only values supported are |
116 |
0 and 1. |
0 and 1. |
117 |
|
|
118 |
|
=item id-string |
119 |
|
|
120 |
|
variable-length string, maximum 25 characters |
121 |
|
|
122 |
=item key-string |
=item key-string |
123 |
|
|
124 |
variable-length string, maximum 40 characters |
variable-length string, maximum 40 characters |
135 |
|
|
136 |
variable-length string, maximum 255 characters |
variable-length string, maximum 255 characters |
137 |
|
|
138 |
|
=item hash-string |
139 |
|
|
140 |
|
variable-length string, maximum 22 characters |
141 |
|
|
142 |
=back |
=back |
143 |
|
|
144 |
|
The hash-string data type has a special meaning. The actual key passed into the loader will |
145 |
|
be a string, but it will be digested into a 22-character MD5 code to save space. Although the |
146 |
|
MD5 algorithm is not perfect, it is extremely unlikely two strings will have the same |
147 |
|
digest. Therefore, it is presumed the keys will be unique. When the database is actually |
148 |
|
in use, the hashed keys will be presented rather than the original values. For this reason, |
149 |
|
they should not be used for entities where the key is meaningful. |
150 |
|
|
151 |
=head3 Global Tags |
=head3 Global Tags |
152 |
|
|
153 |
The entire database definition must be inside a B<Database> tag. The display name of |
The entire database definition must be inside a B<Database> tag. The display name of |
191 |
|
|
192 |
Name of the field. The field name should contain only letters, digits, and hyphens (C<->), |
Name of the field. The field name should contain only letters, digits, and hyphens (C<->), |
193 |
and the first character should be a letter. Most underlying databases are case-insensitive |
and the first character should be a letter. Most underlying databases are case-insensitive |
194 |
with the respect to field names, so a best practice is to use lower-case letters only. |
with the respect to field names, so a best practice is to use lower-case letters only. Finally, |
195 |
|
the name C<search-relevance> has special meaning for full-text searches and should not be |
196 |
|
used as a field name. |
197 |
|
|
198 |
=item type |
=item type |
199 |
|
|
212 |
entity, the fields without a relation attribute are said to belong to the |
entity, the fields without a relation attribute are said to belong to the |
213 |
I<primary relation>. This relation has the same name as the entity itself. |
I<primary relation>. This relation has the same name as the entity itself. |
214 |
|
|
215 |
|
=item searchable |
216 |
|
|
217 |
|
If specified, then the field is a candidate for full-text searching. A single full-text |
218 |
|
index will be created for each relation with at least one searchable field in it. |
219 |
|
For best results, this option should only be used for string or text fields. |
220 |
|
|
221 |
|
=item special |
222 |
|
|
223 |
|
This attribute allows the subclass to assign special meaning for certain fields. |
224 |
|
The interpretation is up to the subclass itself. Currently, only entity fields |
225 |
|
can have this attribute. |
226 |
|
|
227 |
=back |
=back |
228 |
|
|
229 |
=head3 Indexes |
=head3 Indexes |
230 |
|
|
231 |
An entity can have multiple alternate indexes associated with it. The fields must |
An entity can have multiple alternate indexes associated with it. The fields must |
232 |
be from the primary relation. The alternate indexes assist in ordering results |
all be from the same relation. The alternate indexes assist in ordering results |
233 |
from a query. A relationship can have up to two indexes-- a I<to-index> and a |
from a query. A relationship can have up to two indexes-- a I<to-index> and a |
234 |
I<from-index>. These order the results when crossing the relationship. For |
I<from-index>. These order the results when crossing the relationship. For |
235 |
example, in the relationship C<HasContig> from C<Genome> to C<Contig>, the |
example, in the relationship C<HasContig> from C<Genome> to C<Contig>, the |
257 |
|
|
258 |
=back |
=back |
259 |
|
|
260 |
The B<Index>, B<FromIndex>, and B<ToIndex> tags themselves have no attributes. |
The B<FromIndex>, and B<ToIndex> tags have no attributes. The B<Index> tag can |
261 |
|
have a B<Unique> attribute. If specified, the index will be generated as a unique |
262 |
|
index. |
263 |
|
|
264 |
=head3 Object and Field Names |
=head3 Object and Field Names |
265 |
|
|
337 |
|
|
338 |
# Table of information about our datatypes. "sqlType" is the corresponding SQL datatype string. |
# Table of information about our datatypes. "sqlType" is the corresponding SQL datatype string. |
339 |
# "maxLen" is the maximum permissible length of the incoming string data used to populate a field |
# "maxLen" is the maximum permissible length of the incoming string data used to populate a field |
340 |
# of the specified type. "dataGen" is PERL string that will be evaluated if no test data generation |
# of the specified type. "avgLen" is the average byte length for estimating |
341 |
# string is specified in the field definition. "avgLen" is the average byte length for estimating |
# record sizes. "sort" is the key modifier for the sort command, "notes" is a type description, |
342 |
# record sizes. |
# and "indexMod", if non-zero, is the number of characters to use when the field is specified in an |
343 |
my %TypeTable = ( char => { sqlType => 'CHAR(1)', maxLen => 1, avgLen => 1, dataGen => "StringGen('A')" }, |
# index |
344 |
int => { sqlType => 'INTEGER', maxLen => 20, avgLen => 4, dataGen => "IntGen(0, 99999999)" }, |
my %TypeTable = ( char => { sqlType => 'CHAR(1)', maxLen => 1, avgLen => 1, sort => "", |
345 |
string => { sqlType => 'VARCHAR(255)', maxLen => 255, avgLen => 100, dataGen => "StringGen(IntGen(10,250))" }, |
indexMod => 0, notes => "single ASCII character"}, |
346 |
text => { sqlType => 'TEXT', maxLen => 1000000000, avgLen => 500, dataGen => "StringGen(IntGen(80,1000))" }, |
int => { sqlType => 'INTEGER', maxLen => 20, avgLen => 4, sort => "n", |
347 |
date => { sqlType => 'BIGINT', maxLen => 80, avgLen => 8, dataGen => "DateGen(-7, 7, IntGen(0,1400))" }, |
indexMod => 0, notes => "signed 32-bit integer"}, |
348 |
float => { sqlType => 'DOUBLE PRECISION', maxLen => 40, avgLen => 8, dataGen => "FloatGen(0.0, 100.0)" }, |
counter => { sqlType => 'INTEGER UNSIGNED', maxLen => 20, avgLen => 4, sort => "n", |
349 |
boolean => { sqlType => 'SMALLINT', maxLen => 1, avgLen => 1, dataGen => "IntGen(0, 1)" }, |
indexMod => 0, notes => "unsigned 32-bit integer"}, |
350 |
|
string => { sqlType => 'VARCHAR(255)', maxLen => 255, avgLen => 100, sort => "", |
351 |
|
indexMod => 0, notes => "character string, 0 to 255 characters"}, |
352 |
|
text => { sqlType => 'TEXT', maxLen => 1000000000, avgLen => 500, sort => "", |
353 |
|
indexMod => 255, notes => "character string, nearly unlimited length, only first 255 characters are indexed"}, |
354 |
|
date => { sqlType => 'BIGINT', maxLen => 80, avgLen => 8, sort => "n", |
355 |
|
indexMod => 0, notes => "signed, 64-bit integer"}, |
356 |
|
float => { sqlType => 'DOUBLE PRECISION', maxLen => 40, avgLen => 8, sort => "g", |
357 |
|
indexMod => 0, notes => "64-bit double precision floating-point number"}, |
358 |
|
boolean => { sqlType => 'SMALLINT', maxLen => 1, avgLen => 1, sort => "n", |
359 |
|
indexMod => 0, notes => "boolean value: 0 if false, 1 if true"}, |
360 |
|
'hash-string' => |
361 |
|
{ sqlType => 'VARCHAR(22)', maxLen => 22, avgLen => 22, sort => "", |
362 |
|
indexMod => 0, notes => "string stored in digested form, used for certain types of key fields"}, |
363 |
|
'id-string' => |
364 |
|
{ sqlType => 'VARCHAR(25)', maxLen => 25, avgLen => 25, sort => "", |
365 |
|
indexMod => 0, notes => "character string, 0 to 25 characters"}, |
366 |
'key-string' => |
'key-string' => |
367 |
{ sqlType => 'VARCHAR(40)', maxLen => 40, avgLen => 10, dataGen => "StringGen(IntGen(10,40))" }, |
{ sqlType => 'VARCHAR(40)', maxLen => 40, avgLen => 10, sort => "", |
368 |
|
indexMod => 0, notes => "character string, 0 to 40 characters"}, |
369 |
'name-string' => |
'name-string' => |
370 |
{ sqlType => 'VARCHAR(80)', maxLen => 80, avgLen => 40, dataGen => "StringGen(IntGen(10,80))" }, |
{ sqlType => 'VARCHAR(80)', maxLen => 80, avgLen => 40, sort => "", |
371 |
|
indexMod => 0, notes => "character string, 0 to 80 characters"}, |
372 |
'medium-string' => |
'medium-string' => |
373 |
{ sqlType => 'VARCHAR(160)', maxLen => 160, avgLen => 40, dataGen => "StringGen(IntGen(10,160))" }, |
{ sqlType => 'VARCHAR(160)', maxLen => 160, avgLen => 40, sort => "", |
374 |
|
indexMod => 0, notes => "character string, 0 to 160 characters"}, |
375 |
); |
); |
376 |
|
|
377 |
# Table translating arities into natural language. |
# Table translating arities into natural language. |
380 |
'MM' => 'many-to-many' |
'MM' => 'many-to-many' |
381 |
); |
); |
382 |
|
|
383 |
# Table for interpreting string patterns. |
# Options for XML input and output. |
384 |
|
|
385 |
|
my %XmlOptions = (GroupTags => { Relationships => 'Relationship', |
386 |
|
Entities => 'Entity', |
387 |
|
Fields => 'Field', |
388 |
|
Indexes => 'Index', |
389 |
|
IndexFields => 'IndexField' |
390 |
|
}, |
391 |
|
KeyAttr => { Relationship => 'name', |
392 |
|
Entity => 'name', |
393 |
|
Field => 'name' |
394 |
|
}, |
395 |
|
SuppressEmpty => 1, |
396 |
|
); |
397 |
|
|
398 |
my %PictureTable = ( 'A' => "abcdefghijklmnopqrstuvwxyz", |
my %XmlInOpts = ( |
399 |
'9' => "0123456789", |
ForceArray => ['Field', 'Index', 'IndexField', 'Relationship', 'Entity'], |
400 |
'X' => "abcdefghijklmnopqrstuvwxyz0123456789", |
ForceContent => 1, |
401 |
'V' => "aeiou", |
NormalizeSpace => 2, |
|
'K' => "bcdfghjklmnoprstvwxyz" |
|
402 |
); |
); |
403 |
|
my %XmlOutOpts = ( |
404 |
|
RootName => 'Database', |
405 |
|
XMLDecl => 1, |
406 |
|
); |
407 |
|
|
408 |
|
|
409 |
=head2 Public Methods |
=head2 Public Methods |
410 |
|
|
475 |
# Write the HTML heading stuff. |
# Write the HTML heading stuff. |
476 |
print HTMLOUT "<html>\n<head>\n<title>$title</title>\n"; |
print HTMLOUT "<html>\n<head>\n<title>$title</title>\n"; |
477 |
print HTMLOUT "</head>\n<body>\n"; |
print HTMLOUT "</head>\n<body>\n"; |
478 |
|
# Write the documentation. |
479 |
|
print HTMLOUT $self->DisplayMetaData(); |
480 |
|
# Close the document. |
481 |
|
print HTMLOUT "</body>\n</html>\n"; |
482 |
|
# Close the file. |
483 |
|
close HTMLOUT; |
484 |
|
} |
485 |
|
|
486 |
|
=head3 DisplayMetaData |
487 |
|
|
488 |
|
C<< my $html = $erdb->DisplayMetaData(); >> |
489 |
|
|
490 |
|
Return an HTML description of the database. This description can be used to help users create |
491 |
|
the data to be loaded into the relations and form queries. The output is raw includable HTML |
492 |
|
without any HEAD or BODY tags. |
493 |
|
|
494 |
|
=over 4 |
495 |
|
|
496 |
|
=item filename |
497 |
|
|
498 |
|
The name of the output file. |
499 |
|
|
500 |
|
=back |
501 |
|
|
502 |
|
=cut |
503 |
|
|
504 |
|
sub DisplayMetaData { |
505 |
|
# Get the parameters. |
506 |
|
my ($self) = @_; |
507 |
|
# Get the metadata and the title string. |
508 |
|
my $metadata = $self->{_metaData}; |
509 |
|
# Get the title string. |
510 |
|
my $title = $metadata->{Title}; |
511 |
|
# Get the entity and relationship lists. |
512 |
|
my $entityList = $metadata->{Entities}; |
513 |
|
my $relationshipList = $metadata->{Relationships}; |
514 |
|
# Declare the return variable. |
515 |
|
my $retVal = ""; |
516 |
|
# Open the output file. |
517 |
|
Trace("Building MetaData table of contents.") if T(4); |
518 |
# Here we do the table of contents. It starts as an unordered list of section names. Each |
# Here we do the table of contents. It starts as an unordered list of section names. Each |
519 |
# section contains an ordered list of entity or relationship subsections. |
# section contains an ordered list of entity or relationship subsections. |
520 |
print HTMLOUT "<ul>\n<li><a href=\"#EntitiesSection\">Entities</a>\n<ol>\n"; |
$retVal .= "<ul>\n<li><a href=\"#EntitiesSection\">Entities</a>\n<ol>\n"; |
521 |
# Loop through the Entities, displaying a list item for each. |
# Loop through the Entities, displaying a list item for each. |
522 |
foreach my $key (sort keys %{$entityList}) { |
foreach my $key (sort keys %{$entityList}) { |
523 |
# Display this item. |
# Display this item. |
524 |
print HTMLOUT "<li><a href=\"#$key\">$key</a></li>\n"; |
$retVal .= "<li><a href=\"#$key\">$key</a></li>\n"; |
525 |
} |
} |
526 |
# Close off the entity section and start the relationship section. |
# Close off the entity section and start the relationship section. |
527 |
print HTMLOUT "</ol></li>\n<li><a href=\"#RelationshipsSection\">Relationships</a>\n<ol>\n"; |
$retVal .= "</ol></li>\n<li><a href=\"#RelationshipsSection\">Relationships</a>\n<ol>\n"; |
528 |
# Loop through the Relationships. |
# Loop through the Relationships. |
529 |
foreach my $key (sort keys %{$relationshipList}) { |
foreach my $key (sort keys %{$relationshipList}) { |
530 |
# Display this item. |
# Display this item. |
531 |
my $relationshipTitle = _ComputeRelationshipSentence($key, $relationshipList->{$key}); |
my $relationshipTitle = _ComputeRelationshipSentence($key, $relationshipList->{$key}); |
532 |
print HTMLOUT "<li><a href=\"#$key\">$relationshipTitle</a></li>\n"; |
$retVal .= "<li><a href=\"#$key\">$relationshipTitle</a></li>\n"; |
533 |
} |
} |
534 |
# Close off the relationship section and list the join table section. |
# Close off the relationship section and list the join table section. |
535 |
print HTMLOUT "</ol></li>\n<li><a href=\"#JoinTable\">Join Table</a></li>\n"; |
$retVal .= "</ol></li>\n<li><a href=\"#JoinTable\">Join Table</a></li>\n"; |
536 |
# Close off the table of contents itself. |
# Close off the table of contents itself. |
537 |
print HTMLOUT "</ul>\n"; |
$retVal .= "</ul>\n"; |
538 |
# Now we start with the actual data. Denote we're starting the entity section. |
# Now we start with the actual data. Denote we're starting the entity section. |
539 |
print HTMLOUT "<a name=\"EntitiesSection\"></a><h2>Entities</h2>\n"; |
$retVal .= "<a name=\"EntitiesSection\"></a><h2>Entities</h2>\n"; |
540 |
# Loop through the entities. |
# Loop through the entities. |
541 |
for my $key (sort keys %{$entityList}) { |
for my $key (sort keys %{$entityList}) { |
542 |
Trace("Building MetaData entry for $key entity.") if T(4); |
Trace("Building MetaData entry for $key entity.") if T(4); |
543 |
# Create the entity header. It contains a bookmark and the entity name. |
# Create the entity header. It contains a bookmark and the entity name. |
544 |
print HTMLOUT "<a name=\"$key\"></a><h3>$key</h3>\n"; |
$retVal .= "<a name=\"$key\"></a><h3>$key</h3>\n"; |
545 |
# Get the entity data. |
# Get the entity data. |
546 |
my $entityData = $entityList->{$key}; |
my $entityData = $entityList->{$key}; |
547 |
# If there's descriptive text, display it. |
# If there's descriptive text, display it. |
548 |
if (my $notes = $entityData->{Notes}) { |
if (my $notes = $entityData->{Notes}) { |
549 |
print HTMLOUT "<p>" . _HTMLNote($notes->{content}) . "</p>\n"; |
$retVal .= "<p>" . HTMLNote($notes->{content}) . "</p>\n"; |
550 |
} |
} |
551 |
# Now we want a list of the entity's relationships. First, we set up the relationship subsection. |
# See if we need a list of the entity's relationships. |
552 |
print HTMLOUT "<h4>Relationships for <b>$key</b></h4>\n<ul>\n"; |
my $relCount = keys %{$relationshipList}; |
553 |
|
if ($relCount > 0) { |
554 |
|
# First, we set up the relationship subsection. |
555 |
|
$retVal .= "<h4>Relationships for <b>$key</b></h4>\n<ul>\n"; |
556 |
# Loop through the relationships. |
# Loop through the relationships. |
557 |
for my $relationship (sort keys %{$relationshipList}) { |
for my $relationship (sort keys %{$relationshipList}) { |
558 |
# Get the relationship data. |
# Get the relationship data. |
562 |
# Get the relationship sentence and append the arity. |
# Get the relationship sentence and append the arity. |
563 |
my $relationshipDescription = _ComputeRelationshipSentence($relationship, $relationshipStructure); |
my $relationshipDescription = _ComputeRelationshipSentence($relationship, $relationshipStructure); |
564 |
# Display the relationship data. |
# Display the relationship data. |
565 |
print HTMLOUT "<li><a href=\"#$relationship\">$relationshipDescription</a></li>\n"; |
$retVal .= "<li><a href=\"#$relationship\">$relationshipDescription</a></li>\n"; |
566 |
} |
} |
567 |
} |
} |
568 |
# Close off the relationship list. |
# Close off the relationship list. |
569 |
print HTMLOUT "</ul>\n"; |
$retVal .= "</ul>\n"; |
570 |
|
} |
571 |
# Get the entity's relations. |
# Get the entity's relations. |
572 |
my $relationList = $entityData->{Relations}; |
my $relationList = $entityData->{Relations}; |
573 |
# Create a header for the relation subsection. |
# Create a header for the relation subsection. |
574 |
print HTMLOUT "<h4>Relations for <b>$key</b></h4>\n"; |
$retVal .= "<h4>Relations for <b>$key</b></h4>\n"; |
575 |
# Loop through the relations, displaying them. |
# Loop through the relations, displaying them. |
576 |
for my $relation (sort keys %{$relationList}) { |
for my $relation (sort keys %{$relationList}) { |
577 |
my $htmlString = _ShowRelationTable($relation, $relationList->{$relation}); |
my $htmlString = _ShowRelationTable($relation, $relationList->{$relation}); |
578 |
print HTMLOUT $htmlString; |
$retVal .= $htmlString; |
579 |
} |
} |
580 |
} |
} |
581 |
# Denote we're starting the relationship section. |
# Denote we're starting the relationship section. |
582 |
print HTMLOUT "<a name=\"RelationshipsSection\"></a><h2>Relationships</h2>\n"; |
$retVal .= "<a name=\"RelationshipsSection\"></a><h2>Relationships</h2>\n"; |
583 |
# Loop through the relationships. |
# Loop through the relationships. |
584 |
for my $key (sort keys %{$relationshipList}) { |
for my $key (sort keys %{$relationshipList}) { |
585 |
Trace("Building MetaData entry for $key relationship.") if T(4); |
Trace("Building MetaData entry for $key relationship.") if T(4); |
587 |
my $relationshipStructure = $relationshipList->{$key}; |
my $relationshipStructure = $relationshipList->{$key}; |
588 |
# Create the relationship header. |
# Create the relationship header. |
589 |
my $headerText = _ComputeRelationshipHeading($key, $relationshipStructure); |
my $headerText = _ComputeRelationshipHeading($key, $relationshipStructure); |
590 |
print HTMLOUT "<h3><a name=\"$key\"></a>$headerText</h3>\n"; |
$retVal .= "<h3><a name=\"$key\"></a>$headerText</h3>\n"; |
591 |
# Get the entity names. |
# Get the entity names. |
592 |
my $fromEntity = $relationshipStructure->{from}; |
my $fromEntity = $relationshipStructure->{from}; |
593 |
my $toEntity = $relationshipStructure->{to}; |
my $toEntity = $relationshipStructure->{to}; |
597 |
# since both sentences will say the same thing. |
# since both sentences will say the same thing. |
598 |
my $arity = $relationshipStructure->{arity}; |
my $arity = $relationshipStructure->{arity}; |
599 |
if ($arity eq "11") { |
if ($arity eq "11") { |
600 |
print HTMLOUT "<p>Each <b>$fromEntity</b> relates to at most one <b>$toEntity</b>.\n"; |
$retVal .= "<p>Each <b>$fromEntity</b> relates to at most one <b>$toEntity</b>.\n"; |
601 |
} else { |
} else { |
602 |
print HTMLOUT "<p>Each <b>$fromEntity</b> relates to multiple <b>$toEntity</b>s.\n"; |
$retVal .= "<p>Each <b>$fromEntity</b> relates to multiple <b>$toEntity</b>s.\n"; |
603 |
if ($arity eq "MM" && $fromEntity ne $toEntity) { |
if ($arity eq "MM" && $fromEntity ne $toEntity) { |
604 |
print HTMLOUT "Each <b>$toEntity</b> relates to multiple <b>$fromEntity</b>s.\n"; |
$retVal .= "Each <b>$toEntity</b> relates to multiple <b>$fromEntity</b>s.\n"; |
605 |
} |
} |
606 |
} |
} |
607 |
print HTMLOUT "</p>\n"; |
$retVal .= "</p>\n"; |
608 |
# If there are notes on this relationship, display them. |
# If there are notes on this relationship, display them. |
609 |
if (my $notes = $relationshipStructure->{Notes}) { |
if (my $notes = $relationshipStructure->{Notes}) { |
610 |
print HTMLOUT "<p>" . _HTMLNote($notes->{content}) . "</p>\n"; |
$retVal .= "<p>" . HTMLNote($notes->{content}) . "</p>\n"; |
611 |
} |
} |
612 |
# Generate the relationship's relation table. |
# Generate the relationship's relation table. |
613 |
my $htmlString = _ShowRelationTable($key, $relationshipStructure->{Relations}->{$key}); |
my $htmlString = _ShowRelationTable($key, $relationshipStructure->{Relations}->{$key}); |
614 |
print HTMLOUT $htmlString; |
$retVal .= $htmlString; |
615 |
} |
} |
616 |
Trace("Building MetaData join table.") if T(4); |
Trace("Building MetaData join table.") if T(4); |
617 |
# Denote we're starting the join table. |
# Denote we're starting the join table. |
618 |
print HTMLOUT "<a name=\"JoinTable\"></a><h3>Join Table</h3>\n"; |
$retVal .= "<a name=\"JoinTable\"></a><h3>Join Table</h3>\n"; |
619 |
# Create a table header. |
# Create a table header. |
620 |
print HTMLOUT _OpenTable("Join Table", "Source", "Target", "Join Condition"); |
$retVal .= _OpenTable("Join Table", "Source", "Target", "Join Condition"); |
621 |
# Loop through the joins. |
# Loop through the joins. |
622 |
my $joinTable = $metadata->{Joins}; |
my $joinTable = $metadata->{Joins}; |
623 |
my @joinKeys = keys %{$joinTable}; |
my @joinKeys = keys %{$joinTable}; |
630 |
my $target = $self->ComputeObjectSentence($targetRelation); |
my $target = $self->ComputeObjectSentence($targetRelation); |
631 |
my $clause = $joinTable->{$joinKey}; |
my $clause = $joinTable->{$joinKey}; |
632 |
# Display them in a table row. |
# Display them in a table row. |
633 |
print HTMLOUT "<tr><td>$source</td><td>$target</td><td>$clause</td></tr>\n"; |
$retVal .= "<tr><td>$source</td><td>$target</td><td>$clause</td></tr>\n"; |
634 |
} |
} |
635 |
# Close the table. |
# Close the table. |
636 |
print HTMLOUT _CloseTable(); |
$retVal .= _CloseTable(); |
637 |
# Close the document. |
Trace("Built MetaData HTML.") if T(3); |
638 |
print HTMLOUT "</body>\n</html>\n"; |
# Return the HTML. |
639 |
# Close the file. |
return $retVal; |
|
close HTMLOUT; |
|
|
Trace("Built MetaData web page.") if T(3); |
|
640 |
} |
} |
641 |
|
|
642 |
=head3 DumpMetaData |
=head3 DumpMetaData |
654 |
return Data::Dumper::Dumper($self->{_metaData}); |
return Data::Dumper::Dumper($self->{_metaData}); |
655 |
} |
} |
656 |
|
|
657 |
|
=head3 FindIndexForEntity |
658 |
|
|
659 |
|
C<< my $indexFound = ERDB::FindIndexForEntity($xml, $entityName, $attributeName); >> |
660 |
|
|
661 |
|
This method locates the entry in an entity's index list that begins with the |
662 |
|
specified attribute name. If the entity has no index list, one will be |
663 |
|
created. This method works on raw XML, not a live ERDB object. |
664 |
|
|
665 |
|
=over 4 |
666 |
|
|
667 |
|
=item xml |
668 |
|
|
669 |
|
The raw XML structure defining the database. |
670 |
|
|
671 |
|
=item entityName |
672 |
|
|
673 |
|
The name of the relevant entity. |
674 |
|
|
675 |
|
=item attributeName |
676 |
|
|
677 |
|
The name of the attribute relevant to the search. |
678 |
|
|
679 |
|
=item RETURN |
680 |
|
|
681 |
|
The numerical index in the index list of the index entry for the specified entity and |
682 |
|
attribute, or C<undef> if no such index exists. |
683 |
|
|
684 |
|
=back |
685 |
|
|
686 |
|
=cut |
687 |
|
|
688 |
|
sub FindIndexForEntity { |
689 |
|
# Get the parameters. |
690 |
|
my ($xml, $entityName, $attributeName) = @_; |
691 |
|
# Declare the return variable. |
692 |
|
my $retVal; |
693 |
|
# Get the named entity. |
694 |
|
my $entityData = $xml->{Entities}->{$entityName}; |
695 |
|
if (! $entityData) { |
696 |
|
Confess("Entity $entityName not found in DBD structure."); |
697 |
|
} else { |
698 |
|
# Insure it has an index list. |
699 |
|
if (! exists $entityData->{Indexes}) { |
700 |
|
$entityData->{Indexes} = []; |
701 |
|
} else { |
702 |
|
# Search for the desired index. |
703 |
|
my $indexList = $entityData->{Indexes}; |
704 |
|
my $n = scalar @{$indexList}; |
705 |
|
Trace("Searching $n indexes in index list for $entityName.") if T(2); |
706 |
|
# We use an indexed FOR here because we're returning an |
707 |
|
# index number instead of an object. We do THAT so we can |
708 |
|
# delete the index from the list if needed. |
709 |
|
for (my $i = 0; $i < $n && !defined($retVal); $i++) { |
710 |
|
my $index = $indexList->[$i]; |
711 |
|
my $fields = $index->{IndexFields}; |
712 |
|
# Technically this IF should be safe (that is, we are guaranteed |
713 |
|
# the existence of a "$fields->[0]"), because when we load the XML |
714 |
|
# we have SuppressEmpty specified. |
715 |
|
if ($fields->[0]->{name} eq $attributeName) { |
716 |
|
$retVal = $i; |
717 |
|
} |
718 |
|
} |
719 |
|
} |
720 |
|
} |
721 |
|
Trace("Index for $attributeName of $entityName found at position $retVal.") if defined($retVal) && T(3); |
722 |
|
Trace("Index for $attributeName not found in $entityName.") if !defined($retVal) && T(3); |
723 |
|
# Return the result. |
724 |
|
return $retVal; |
725 |
|
} |
726 |
|
|
727 |
=head3 CreateTables |
=head3 CreateTables |
728 |
|
|
729 |
C<< $erdb->CreateTables(); >> |
C<< $erdb->CreateTables(); >> |
811 |
Trace("Creating table $relationName: $fieldThing") if T(2); |
Trace("Creating table $relationName: $fieldThing") if T(2); |
812 |
$dbh->create_table(tbl => $relationName, flds => $fieldThing, estimates => $estimation); |
$dbh->create_table(tbl => $relationName, flds => $fieldThing, estimates => $estimation); |
813 |
Trace("Relation $relationName created in database.") if T(2); |
Trace("Relation $relationName created in database.") if T(2); |
814 |
# If we want to build the indexes, we do it here. |
# If we want to build the indexes, we do it here. Note that the full-text search |
815 |
|
# index will not be built until the table has been loaded. |
816 |
if ($indexFlag) { |
if ($indexFlag) { |
817 |
$self->CreateIndex($relationName); |
$self->CreateIndex($relationName); |
818 |
} |
} |
873 |
return $retVal; |
return $retVal; |
874 |
} |
} |
875 |
|
|
876 |
|
=head3 DigestFields |
877 |
|
|
878 |
|
C<< $erdb->DigestFields($relName, $fieldList); >> |
879 |
|
|
880 |
|
Digest the strings in the field list that correspond to data type C<hash-string> in the |
881 |
|
specified relation. |
882 |
|
|
883 |
|
=over 4 |
884 |
|
|
885 |
|
=item relName |
886 |
|
|
887 |
|
Name of the relation to which the fields belong. |
888 |
|
|
889 |
|
=item fieldList |
890 |
|
|
891 |
|
List of field contents to be loaded into the relation. |
892 |
|
|
893 |
|
=back |
894 |
|
|
895 |
|
=cut |
896 |
|
#: Return Type ; |
897 |
|
sub DigestFields { |
898 |
|
# Get the parameters. |
899 |
|
my ($self, $relName, $fieldList) = @_; |
900 |
|
# Get the relation definition. |
901 |
|
my $relData = $self->_FindRelation($relName); |
902 |
|
# Get the list of field descriptors. |
903 |
|
my $fieldTypes = $relData->{Fields}; |
904 |
|
my $fieldCount = scalar @{$fieldTypes}; |
905 |
|
# Loop through the two lists. |
906 |
|
for (my $i = 0; $i < $fieldCount; $i++) { |
907 |
|
# Get the type of the current field. |
908 |
|
my $fieldType = $fieldTypes->[$i]->{type}; |
909 |
|
# If it's a hash string, digest it in place. |
910 |
|
if ($fieldType eq 'hash-string') { |
911 |
|
$fieldList->[$i] = $self->DigestKey($fieldList->[$i]); |
912 |
|
} |
913 |
|
} |
914 |
|
} |
915 |
|
|
916 |
|
=head3 DigestKey |
917 |
|
|
918 |
|
C<< my $digested = $erdb->DigestKey($keyValue); >> |
919 |
|
|
920 |
|
Return the digested value of a symbolic key. The digested value can then be plugged into a |
921 |
|
key-based search into a table with key-type hash-string. |
922 |
|
|
923 |
|
Currently the digesting process is independent of the database structure, but that may not |
924 |
|
always be the case, so this is an instance method instead of a static method. |
925 |
|
|
926 |
|
=over 4 |
927 |
|
|
928 |
|
=item keyValue |
929 |
|
|
930 |
|
Key value to digest. |
931 |
|
|
932 |
|
=item RETURN |
933 |
|
|
934 |
|
Digested value of the key. |
935 |
|
|
936 |
|
=back |
937 |
|
|
938 |
|
=cut |
939 |
|
|
940 |
|
sub DigestKey { |
941 |
|
# Get the parameters. |
942 |
|
my ($self, $keyValue) = @_; |
943 |
|
# Compute the digest. |
944 |
|
my $retVal = md5_base64($keyValue); |
945 |
|
# Return the result. |
946 |
|
return $retVal; |
947 |
|
} |
948 |
|
|
949 |
=head3 CreateIndex |
=head3 CreateIndex |
950 |
|
|
951 |
C<< $erdb->CreateIndex($relationName); >> |
C<< $erdb->CreateIndex($relationName); >> |
969 |
for my $indexName (keys %{$indexHash}) { |
for my $indexName (keys %{$indexHash}) { |
970 |
my $indexData = $indexHash->{$indexName}; |
my $indexData = $indexHash->{$indexName}; |
971 |
# Get the index's field list. |
# Get the index's field list. |
972 |
my @fieldList = _FixNames(@{$indexData->{IndexFields}}); |
my @rawFields = @{$indexData->{IndexFields}}; |
973 |
|
# Get a hash of the relation's field types. |
974 |
|
my %types = map { $_->{name} => $_->{type} } @{$relationData->{Fields}}; |
975 |
|
# We need to check for text fields so we can append a length limitation for them. To do |
976 |
|
# that, we need the relation's field list. |
977 |
|
my $relFields = $relationData->{Fields}; |
978 |
|
for (my $i = 0; $i <= $#rawFields; $i++) { |
979 |
|
# Get the field type. |
980 |
|
my $field = $rawFields[$i]; |
981 |
|
my $type = $types{$field}; |
982 |
|
# Ask if it requires using prefix notation for the index. |
983 |
|
my $mod = $TypeTable{$type}->{indexMod}; |
984 |
|
Trace("Field $field ($i) in $relationName has type $type and indexMod $mod.") if T(3); |
985 |
|
if ($mod) { |
986 |
|
# Append the prefix length to the field name, |
987 |
|
$rawFields[$i] .= "($mod)"; |
988 |
|
} |
989 |
|
} |
990 |
|
my @fieldList = _FixNames(@rawFields); |
991 |
my $flds = join(', ', @fieldList); |
my $flds = join(', ', @fieldList); |
992 |
# Get the index's uniqueness flag. |
# Get the index's uniqueness flag. |
993 |
my $unique = (exists $indexData->{Unique} ? $indexData->{Unique} : 'false'); |
my $unique = (exists $indexData->{Unique} ? 'unique' : undef); |
994 |
# Create the index. |
# Create the index. |
995 |
my $rv = $dbh->create_index(idx => $indexName, tbl => $relationName, |
my $rv = $dbh->create_index(idx => $indexName, tbl => $relationName, |
996 |
flds => $flds, unique => $unique); |
flds => $flds, kind => $unique); |
997 |
if ($rv) { |
if ($rv) { |
998 |
Trace("Index created: $indexName for $relationName ($flds)") if T(1); |
Trace("Index created: $indexName for $relationName ($flds)") if T(1); |
999 |
} else { |
} else { |
1002 |
} |
} |
1003 |
} |
} |
1004 |
|
|
1005 |
|
=head3 GetSecondaryFields |
1006 |
|
|
1007 |
|
C<< my %fieldTuples = $erdb->GetSecondaryFields($entityName); >> |
1008 |
|
|
1009 |
|
This method will return a list of the name and type of each of the secondary |
1010 |
|
fields for a specified entity. Secondary fields are stored in two-column tables |
1011 |
|
in addition to the primary entity table. This enables the field to have no value |
1012 |
|
or to have multiple values. |
1013 |
|
|
1014 |
|
=over 4 |
1015 |
|
|
1016 |
|
=item entityName |
1017 |
|
|
1018 |
|
Name of the entity whose secondary fields are desired. |
1019 |
|
|
1020 |
|
=item RETURN |
1021 |
|
|
1022 |
|
Returns a hash mapping the field names to their field types. |
1023 |
|
|
1024 |
|
=back |
1025 |
|
|
1026 |
|
=cut |
1027 |
|
|
1028 |
|
sub GetSecondaryFields { |
1029 |
|
# Get the parameters. |
1030 |
|
my ($self, $entityName) = @_; |
1031 |
|
# Declare the return variable. |
1032 |
|
my %retVal = (); |
1033 |
|
# Look for the entity. |
1034 |
|
my $table = $self->GetFieldTable($entityName); |
1035 |
|
# Loop through the fields, pulling out the secondaries. |
1036 |
|
for my $field (sort keys %{$table}) { |
1037 |
|
if ($table->{$field}->{relation} ne $entityName) { |
1038 |
|
# Here we have a secondary field. |
1039 |
|
$retVal{$field} = $table->{$field}->{type}; |
1040 |
|
} |
1041 |
|
} |
1042 |
|
# Return the result. |
1043 |
|
return %retVal; |
1044 |
|
} |
1045 |
|
|
1046 |
|
=head3 GetFieldRelationName |
1047 |
|
|
1048 |
|
C<< my $name = $erdb->GetFieldRelationName($objectName, $fieldName); >> |
1049 |
|
|
1050 |
|
Return the name of the relation containing a specified field. |
1051 |
|
|
1052 |
|
=over 4 |
1053 |
|
|
1054 |
|
=item objectName |
1055 |
|
|
1056 |
|
Name of the entity or relationship containing the field. |
1057 |
|
|
1058 |
|
=item fieldName |
1059 |
|
|
1060 |
|
Name of the relevant field in that entity or relationship. |
1061 |
|
|
1062 |
|
=item RETURN |
1063 |
|
|
1064 |
|
Returns the name of the database relation containing the field, or C<undef> if |
1065 |
|
the field does not exist. |
1066 |
|
|
1067 |
|
=back |
1068 |
|
|
1069 |
|
=cut |
1070 |
|
|
1071 |
|
sub GetFieldRelationName { |
1072 |
|
# Get the parameters. |
1073 |
|
my ($self, $objectName, $fieldName) = @_; |
1074 |
|
# Declare the return variable. |
1075 |
|
my $retVal; |
1076 |
|
# Get the object field table. |
1077 |
|
my $table = $self->GetFieldTable($objectName); |
1078 |
|
# Only proceed if the field exists. |
1079 |
|
if (exists $table->{$fieldName}) { |
1080 |
|
# Determine the name of the relation that contains this field. |
1081 |
|
$retVal = $table->{$fieldName}->{relation}; |
1082 |
|
} |
1083 |
|
# Return the result. |
1084 |
|
return $retVal; |
1085 |
|
} |
1086 |
|
|
1087 |
|
=head3 DeleteValue |
1088 |
|
|
1089 |
|
C<< my $numDeleted = $erdb->DeleteValue($entityName, $id, $fieldName, $fieldValue); >> |
1090 |
|
|
1091 |
|
Delete secondary field values from the database. This method can be used to delete all |
1092 |
|
values of a specified field for a particular entity instance, or only a single value. |
1093 |
|
|
1094 |
|
Secondary fields are stored in two-column relations separate from an entity's primary |
1095 |
|
table, and as a result a secondary field can legitimately have no value or multiple |
1096 |
|
values. Therefore, it makes sense to talk about deleting secondary fields where it |
1097 |
|
would not make sense for primary fields. |
1098 |
|
|
1099 |
|
=over 4 |
1100 |
|
|
1101 |
|
=item entityName |
1102 |
|
|
1103 |
|
Name of the entity from which the fields are to be deleted. |
1104 |
|
|
1105 |
|
=item id |
1106 |
|
|
1107 |
|
ID of the entity instance to be processed. If the instance is not found, this |
1108 |
|
method will have no effect. If C<undef> is specified, all values for all of |
1109 |
|
the entity instances will be deleted. |
1110 |
|
|
1111 |
|
=item fieldName |
1112 |
|
|
1113 |
|
Name of the field whose values are to be deleted. |
1114 |
|
|
1115 |
|
=item fieldValue (optional) |
1116 |
|
|
1117 |
|
Value to be deleted. If not specified, then all values of the specified field |
1118 |
|
will be deleted for the entity instance. If specified, then only the values which |
1119 |
|
match this parameter will be deleted. |
1120 |
|
|
1121 |
|
=item RETURN |
1122 |
|
|
1123 |
|
Returns the number of rows deleted. |
1124 |
|
|
1125 |
|
=back |
1126 |
|
|
1127 |
|
=cut |
1128 |
|
|
1129 |
|
sub DeleteValue { |
1130 |
|
# Get the parameters. |
1131 |
|
my ($self, $entityName, $id, $fieldName, $fieldValue) = @_; |
1132 |
|
# Declare the return value. |
1133 |
|
my $retVal = 0; |
1134 |
|
# We need to set up an SQL command to do the deletion. First, we |
1135 |
|
# find the name of the field's relation. |
1136 |
|
my $table = $self->GetFieldTable($entityName); |
1137 |
|
my $field = $table->{$fieldName}; |
1138 |
|
my $relation = $field->{relation}; |
1139 |
|
# Make sure this is a secondary field. |
1140 |
|
if ($relation eq $entityName) { |
1141 |
|
Confess("Cannot delete values of $fieldName for $entityName."); |
1142 |
|
} else { |
1143 |
|
# Set up the SQL command to delete all values. |
1144 |
|
my $sql = "DELETE FROM $relation"; |
1145 |
|
# Build the filter. |
1146 |
|
my @filters = (); |
1147 |
|
my @parms = (); |
1148 |
|
# Check for a filter by ID. |
1149 |
|
if (defined $id) { |
1150 |
|
push @filters, "id = ?"; |
1151 |
|
push @parms, $id; |
1152 |
|
} |
1153 |
|
# Check for a filter by value. |
1154 |
|
if (defined $fieldValue) { |
1155 |
|
push @filters, "$fieldName = ?"; |
1156 |
|
push @parms, $fieldValue; |
1157 |
|
} |
1158 |
|
# Append the filters to the command. |
1159 |
|
if (@filters) { |
1160 |
|
$sql .= " WHERE " . join(" AND ", @filters); |
1161 |
|
} |
1162 |
|
# Execute the command. |
1163 |
|
my $dbh = $self->{_dbh}; |
1164 |
|
$retVal = $dbh->SQL($sql, 0, @parms); |
1165 |
|
} |
1166 |
|
# Return the result. |
1167 |
|
return $retVal; |
1168 |
|
} |
1169 |
|
|
1170 |
=head3 LoadTables |
=head3 LoadTables |
1171 |
|
|
1172 |
C<< my $stats = $erdb->LoadTables($directoryName, $rebuild); >> |
C<< my $stats = $erdb->LoadTables($directoryName, $rebuild); >> |
1261 |
return sort keys %{$entityList}; |
return sort keys %{$entityList}; |
1262 |
} |
} |
1263 |
|
|
1264 |
|
=head3 GetDataTypes |
1265 |
|
|
1266 |
|
C<< my %types = ERDB::GetDataTypes(); >> |
1267 |
|
|
1268 |
|
Return a table of ERDB data types. The table returned is a hash of hashes. |
1269 |
|
The keys of the big hash are the datatypes. Each smaller hash has several |
1270 |
|
values used to manage the data. The most interesting is the SQL type (key |
1271 |
|
C<sqlType>) and the descriptive node (key C<notes>). |
1272 |
|
|
1273 |
|
Note that changing the values in the smaller hashes will seriously break |
1274 |
|
things, so this data should be treated as read-only. |
1275 |
|
|
1276 |
|
=cut |
1277 |
|
|
1278 |
|
sub GetDataTypes { |
1279 |
|
return %TypeTable; |
1280 |
|
} |
1281 |
|
|
1282 |
|
|
1283 |
=head3 IsEntity |
=head3 IsEntity |
1284 |
|
|
1285 |
C<< my $flag = $erdb->IsEntity($entityName); >> |
C<< my $flag = $erdb->IsEntity($entityName); >> |
1309 |
|
|
1310 |
=head3 Get |
=head3 Get |
1311 |
|
|
1312 |
C<< my $query = $erdb->Get(\@objectNames, $filterClause, $param1, $param2, ..., $paramN); >> |
C<< my $query = $erdb->Get(\@objectNames, $filterClause, \@params); >> |
1313 |
|
|
1314 |
This method returns a query object for entities of a specified type using a specified filter. |
This method returns a query object for entities of a specified type using a specified filter. |
1315 |
The filter is a standard WHERE/ORDER BY clause with question marks as parameter markers and each |
The filter is a standard WHERE/ORDER BY clause with question marks as parameter markers and each |
1317 |
following call requests all B<Genome> objects for the genus specified in the variable |
following call requests all B<Genome> objects for the genus specified in the variable |
1318 |
$genus. |
$genus. |
1319 |
|
|
1320 |
C<< $query = $erdb->Get(['Genome'], "Genome(genus) = ?", $genus); >> |
C<< $query = $erdb->Get(['Genome'], "Genome(genus) = ?", [$genus]); >> |
1321 |
|
|
1322 |
The WHERE clause contains a single question mark, so there is a single additional |
The WHERE clause contains a single question mark, so there is a single additional |
1323 |
parameter representing the parameter value. It would also be possible to code |
parameter representing the parameter value. It would also be possible to code |
1334 |
It is possible to specify multiple entity and relationship names in order to retrieve more than |
It is possible to specify multiple entity and relationship names in order to retrieve more than |
1335 |
one object's data at the same time, which allows highly complex joined queries. For example, |
one object's data at the same time, which allows highly complex joined queries. For example, |
1336 |
|
|
1337 |
C<< $query = $erdb->Get(['Genome', 'ComesFrom', 'Source'], "Genome(genus) = ?", $genus); >> |
C<< $query = $erdb->Get(['Genome', 'ComesFrom', 'Source'], "Genome(genus) = ?", [$genus]); >> |
1338 |
|
|
1339 |
If multiple names are specified, then the query processor will automatically determine a |
If multiple names are specified, then the query processor will automatically determine a |
1340 |
join path between the entities and relationships. The algorithm used is very simplistic. |
join path between the entities and relationships. The algorithm used is very simplistic. |
1341 |
In particular, you can't specify any entity or relationship more than once, and if a |
In particular, if a relationship is recursive, the path is determined by the order in which |
1342 |
relationship is recursive, the path is determined by the order in which the entity |
the entity and the relationship appear. For example, consider a recursive relationship |
1343 |
and the relationship appear. For example, consider a recursive relationship B<IsParentOf> |
B<IsParentOf> which relates B<People> objects to other B<People> objects. If the join path is |
|
which relates B<People> objects to other B<People> objects. If the join path is |
|
1344 |
coded as C<['People', 'IsParentOf']>, then the people returned will be parents. If, however, |
coded as C<['People', 'IsParentOf']>, then the people returned will be parents. If, however, |
1345 |
the join path is C<['IsParentOf', 'People']>, then the people returned will be children. |
the join path is C<['IsParentOf', 'People']>, then the people returned will be children. |
1346 |
|
|
1347 |
|
If an entity or relationship is mentioned twice, the name for the second occurrence will |
1348 |
|
be suffixed with C<2>, the third occurrence will be suffixed with C<3>, and so forth. So, |
1349 |
|
for example, if we have C<['Feature', 'HasContig', 'Contig', 'HasContig']>, then the |
1350 |
|
B<to-link> field of the first B<HasContig> is specified as C<HasContig(to-link)>, while |
1351 |
|
the B<to-link> field of the second B<HasContig> is specified as C<HasContig2(to-link)>. |
1352 |
|
|
1353 |
=over 4 |
=over 4 |
1354 |
|
|
1355 |
=item objectNames |
=item objectNames |
1379 |
filter clause in general; however, odd things may happen if a sort field is from a secondary |
filter clause in general; however, odd things may happen if a sort field is from a secondary |
1380 |
relation. |
relation. |
1381 |
|
|
1382 |
=item param1, param2, ..., paramN |
Finally, you can limit the number of rows returned by adding a LIMIT clause. The LIMIT must |
1383 |
|
be the last thing in the filter clause, and it contains only the word "LIMIT" followed by |
1384 |
|
a positive number. So, for example |
1385 |
|
|
1386 |
|
C<< "Genome(genus) = ? ORDER BY Genome(species) LIMIT 10" >> |
1387 |
|
|
1388 |
|
will only return the first ten genomes for the specified genus. The ORDER BY clause is not |
1389 |
|
required. For example, to just get the first 10 genomes in the B<Genome> table, you could |
1390 |
|
use |
1391 |
|
|
1392 |
|
C<< "LIMIT 10" >> |
1393 |
|
|
1394 |
Parameter values to be substituted into the filter clause. |
=item params |
1395 |
|
|
1396 |
|
Reference to a list of parameter values to be substituted into the filter clause. |
1397 |
|
|
1398 |
=item RETURN |
=item RETURN |
1399 |
|
|
1405 |
|
|
1406 |
sub Get { |
sub Get { |
1407 |
# Get the parameters. |
# Get the parameters. |
1408 |
my ($self, $objectNames, $filterClause, @params) = @_; |
my ($self, $objectNames, $filterClause, $params) = @_; |
1409 |
# Construct the SELECT statement. The general pattern is |
# Process the SQL stuff. |
1410 |
# |
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = |
1411 |
# SELECT name1.*, name2.*, ... nameN.* FROM name1, name2, ... nameN |
$self->_SetupSQL($objectNames, $filterClause); |
1412 |
# |
# Create the query. |
1413 |
my $dbh = $self->{_dbh}; |
my $command = "SELECT DISTINCT " . join(".*, ", @{$mappedNameListRef}) . |
1414 |
my $command = "SELECT DISTINCT " . join('.*, ', @{$objectNames}) . ".* FROM " . |
".* $suffix"; |
1415 |
join(', ', @{$objectNames}); |
my $sth = $self->_GetStatementHandle($command, $params); |
1416 |
# Check for a filter clause. |
# Now we create the relation map, which enables DBQuery to determine the order, name |
1417 |
if ($filterClause) { |
# and mapped name for each object in the query. |
1418 |
# Here we have one, so we convert its field names and add it to the query. First, |
my @relationMap = (); |
1419 |
# We create a copy of the filter string we can work with. |
for my $mappedName (@{$mappedNameListRef}) { |
1420 |
my $filterString = $filterClause; |
push @relationMap, [$mappedName, $mappedNameHashRef->{$mappedName}]; |
|
# Next, we sort the object names by length. This helps protect us from finding |
|
|
# object names inside other object names when we're doing our search and replace. |
|
|
my @sortedNames = sort { length($b) - length($a) } @{$objectNames}; |
|
|
# We will also keep a list of conditions to add to the WHERE clause in order to link |
|
|
# entities and relationships as well as primary relations to secondary ones. |
|
|
my @joinWhere = (); |
|
|
# The final preparatory step is to create a hash table of relation names. The |
|
|
# table begins with the relation names already in the SELECT command. |
|
|
my %fromNames = (); |
|
|
for my $objectName (@sortedNames) { |
|
|
$fromNames{$objectName} = 1; |
|
|
} |
|
|
# We are ready to begin. We loop through the object names, replacing each |
|
|
# object name's field references by the corresponding SQL field reference. |
|
|
# Along the way, if we find a secondary relation, we will need to add it |
|
|
# to the FROM clause. |
|
|
for my $objectName (@sortedNames) { |
|
|
# Get the length of the object name plus 2. This is the value we add to the |
|
|
# size of the field name to determine the size of the field reference as a |
|
|
# whole. |
|
|
my $nameLength = 2 + length $objectName; |
|
|
# Get the object's field list. |
|
|
my $fieldList = $self->_GetFieldTable($objectName); |
|
|
# Find the field references for this object. |
|
|
while ($filterString =~ m/$objectName\(([^)]*)\)/g) { |
|
|
# At this point, $1 contains the field name, and the current position |
|
|
# is set immediately after the final parenthesis. We pull out the name of |
|
|
# the field and the position and length of the field reference as a whole. |
|
|
my $fieldName = $1; |
|
|
my $len = $nameLength + length $fieldName; |
|
|
my $pos = pos($filterString) - $len; |
|
|
# Insure the field exists. |
|
|
if (!exists $fieldList->{$fieldName}) { |
|
|
Confess("Field $fieldName not found for object $objectName."); |
|
|
} else { |
|
|
# Get the field's relation. |
|
|
my $relationName = $fieldList->{$fieldName}->{relation}; |
|
|
# Insure the relation is in the FROM clause. |
|
|
if (!exists $fromNames{$relationName}) { |
|
|
# Add the relation to the FROM clause. |
|
|
$command .= ", $relationName"; |
|
|
# Create its join sub-clause. |
|
|
push @joinWhere, "$objectName.id = $relationName.id"; |
|
|
# Denote we have it available for future fields. |
|
|
$fromNames{$relationName} = 1; |
|
|
} |
|
|
# Form an SQL field reference from the relation name and the field name. |
|
|
my $sqlReference = "$relationName." . _FixName($fieldName); |
|
|
# Put it into the filter string in place of the old value. |
|
|
substr($filterString, $pos, $len) = $sqlReference; |
|
|
# Reposition the search. |
|
|
pos $filterString = $pos + length $sqlReference; |
|
|
} |
|
1421 |
} |
} |
1422 |
|
# Return the statement object. |
1423 |
|
my $retVal = DBQuery::_new($self, $sth, \@relationMap); |
1424 |
|
return $retVal; |
1425 |
} |
} |
1426 |
# The next step is to join the objects together. We only need to do this if there |
|
1427 |
# is more than one object in the object list. We start with the first object and |
|
1428 |
# run through the objects after it. Note also that we make a safety copy of the |
|
1429 |
# list before running through it. |
=head3 Search |
1430 |
my @objectList = @{$objectNames}; |
|
1431 |
my $lastObject = shift @objectList; |
C<< my $query = $erdb->Search($searchExpression, $idx, \@objectNames, $filterClause, \@params); >> |
1432 |
# Get the join table. |
|
1433 |
my $joinTable = $self->{_metaData}->{Joins}; |
Perform a full text search with filtering. The search will be against a specified object |
1434 |
# Loop through the object list. |
in the object name list. That object will get an extra field containing the search |
1435 |
for my $thisObject (@objectList) { |
relevance. Note that except for the search expression, the parameters of this method are |
1436 |
# Look for a join. |
the same as those for L</Get> and follow the same rules. |
1437 |
my $joinKey = "$lastObject/$thisObject"; |
|
1438 |
if (!exists $joinTable->{$joinKey}) { |
=over 4 |
1439 |
# Here there's no join, so we throw an error. |
|
1440 |
Confess("No join exists to connect from $lastObject to $thisObject."); |
=item searchExpression |
1441 |
|
|
1442 |
|
Boolean search expression for the text fields of the target object. The default mode for |
1443 |
|
a Boolean search expression is OR, but we want the default to be AND, so we will |
1444 |
|
add a C<+> operator to each word with no other operator before it. |
1445 |
|
|
1446 |
|
=item idx |
1447 |
|
|
1448 |
|
Index in the I<$objectNames> list of the table to be searched in full-text mode. |
1449 |
|
|
1450 |
|
=item objectNames |
1451 |
|
|
1452 |
|
List containing the names of the entity and relationship objects to be retrieved. |
1453 |
|
|
1454 |
|
=item filterClause |
1455 |
|
|
1456 |
|
WHERE clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can |
1457 |
|
be parameterized with parameter markers (C<?>). Each field used in the WHERE clause must be |
1458 |
|
specified in the standard form B<I<objectName>(I<fieldName>)>. Any parameters specified |
1459 |
|
in the filter clause should be added to the parameter list as additional parameters. The |
1460 |
|
fields in a filter clause can come from primary entity relations, relationship relations, |
1461 |
|
or secondary entity relations; however, all of the entities and relationships involved must |
1462 |
|
be included in the list of object names. |
1463 |
|
|
1464 |
|
=item params |
1465 |
|
|
1466 |
|
Reference to a list of parameter values to be substituted into the filter clause. |
1467 |
|
|
1468 |
|
=item RETURN |
1469 |
|
|
1470 |
|
Returns a query object for the specified search. |
1471 |
|
|
1472 |
|
=back |
1473 |
|
|
1474 |
|
=cut |
1475 |
|
|
1476 |
|
sub Search { |
1477 |
|
# Get the parameters. |
1478 |
|
my ($self, $searchExpression, $idx, $objectNames, $filterClause, $params) = @_; |
1479 |
|
# Declare the return variable. |
1480 |
|
my $retVal; |
1481 |
|
# Create a safety copy of the parameter list. Note we have to be careful to insure |
1482 |
|
# a parameter list exists before we copy it. |
1483 |
|
my @myParams = (); |
1484 |
|
if (defined $params) { |
1485 |
|
@myParams = @{$params}; |
1486 |
|
} |
1487 |
|
# Get the first object's structure so we have access to the searchable fields. |
1488 |
|
my $object1Name = $objectNames->[$idx]; |
1489 |
|
my $object1Structure = $self->_GetStructure($object1Name); |
1490 |
|
# Get the field list. |
1491 |
|
if (! exists $object1Structure->{searchFields}) { |
1492 |
|
Confess("No searchable index for $object1Name."); |
1493 |
} else { |
} else { |
1494 |
# Get the join clause and add it to the WHERE list. |
# Get the field list. |
1495 |
push @joinWhere, $joinTable->{$joinKey}; |
my @fields = @{$object1Structure->{searchFields}}; |
1496 |
# Save this object as the last object for the next iteration. |
# Clean the search expression. |
1497 |
$lastObject = $thisObject; |
my $actualKeywords = $self->CleanKeywords($searchExpression); |
1498 |
} |
# Prefix a "+" to each uncontrolled word. This converts the default |
1499 |
|
# search mode from OR to AND. |
1500 |
|
$actualKeywords =~ s/(^|\s)(\w|")/$1\+$2/g; |
1501 |
|
Trace("Actual keywords for search are\n$actualKeywords") if T(3); |
1502 |
|
# We need two match expressions, one for the filter clause and one in the |
1503 |
|
# query itself. Both will use a parameter mark, so we need to push the |
1504 |
|
# search expression onto the front of the parameter list twice. |
1505 |
|
unshift @myParams, $actualKeywords, $actualKeywords; |
1506 |
|
# Build the match expression. |
1507 |
|
my @matchFilterFields = map { "$object1Name." . _FixName($_) } @fields; |
1508 |
|
my $matchClause = "MATCH (" . join(", ", @matchFilterFields) . ") AGAINST (? IN BOOLEAN MODE)"; |
1509 |
|
# Process the SQL stuff. |
1510 |
|
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = |
1511 |
|
$self->_SetupSQL($objectNames, $filterClause, $matchClause); |
1512 |
|
# Create the query. Note that the match clause is inserted at the front of |
1513 |
|
# the select fields. |
1514 |
|
my $command = "SELECT DISTINCT $matchClause, " . join(".*, ", @{$mappedNameListRef}) . |
1515 |
|
".* $suffix"; |
1516 |
|
my $sth = $self->_GetStatementHandle($command, \@myParams); |
1517 |
|
# Now we create the relation map, which enables DBQuery to determine the order, name |
1518 |
|
# and mapped name for each object in the query. |
1519 |
|
my @relationMap = _RelationMap($mappedNameHashRef, $mappedNameListRef); |
1520 |
|
# Return the statement object. |
1521 |
|
$retVal = DBQuery::_new($self, $sth, \@relationMap, $object1Name); |
1522 |
} |
} |
1523 |
# Now we need to handle the whole ORDER BY / LIMIT thing. The important part |
return $retVal; |
|
# here is we want the filter clause to be empty if there's no WHERE filter. |
|
|
# We'll put the ORDER BY / LIMIT clauses in the following variable. |
|
|
my $orderClause = ""; |
|
|
# Locate the ORDER BY or LIMIT verbs (if any). We use a non-greedy |
|
|
# operator so that we find the first occurrence of either verb. |
|
|
if ($filterString =~ m/^(.*?)\s*(ORDER BY|LIMIT)/g) { |
|
|
# Here we have an ORDER BY or LIMIT verb. Split it off of the filter string. |
|
|
my $pos = pos $filterString; |
|
|
$orderClause = $2 . substr($filterString, $pos); |
|
|
$filterString = $1; |
|
1524 |
} |
} |
1525 |
# Add the filter and the join clauses (if any) to the SELECT command. |
|
1526 |
if ($filterString) { |
=head3 GetFlat |
1527 |
push @joinWhere, "($filterString)"; |
|
1528 |
|
C<< my @list = $erdb->GetFlat(\@objectNames, $filterClause, \@parameterList, $field); >> |
1529 |
|
|
1530 |
|
This is a variation of L</GetAll> that asks for only a single field per record and |
1531 |
|
returns a single flattened list. |
1532 |
|
|
1533 |
|
=over 4 |
1534 |
|
|
1535 |
|
=item objectNames |
1536 |
|
|
1537 |
|
List containing the names of the entity and relationship objects to be retrieved. |
1538 |
|
|
1539 |
|
=item filterClause |
1540 |
|
|
1541 |
|
WHERE/ORDER BY clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can |
1542 |
|
be parameterized with parameter markers (C<?>). Each field used must be specified in the standard form |
1543 |
|
B<I<objectName>(I<fieldName>)>. Any parameters specified in the filter clause should be added to the |
1544 |
|
parameter list as additional parameters. The fields in a filter clause can come from primary |
1545 |
|
entity relations, relationship relations, or secondary entity relations; however, all of the |
1546 |
|
entities and relationships involved must be included in the list of object names. |
1547 |
|
|
1548 |
|
=item parameterList |
1549 |
|
|
1550 |
|
List of the parameters to be substituted in for the parameters marks in the filter clause. |
1551 |
|
|
1552 |
|
=item field |
1553 |
|
|
1554 |
|
Name of the field to be used to get the elements of the list returned. |
1555 |
|
|
1556 |
|
=item RETURN |
1557 |
|
|
1558 |
|
Returns a list of values. |
1559 |
|
|
1560 |
|
=back |
1561 |
|
|
1562 |
|
=cut |
1563 |
|
#: Return Type @; |
1564 |
|
sub GetFlat { |
1565 |
|
# Get the parameters. |
1566 |
|
my ($self, $objectNames, $filterClause, $parameterList, $field) = @_; |
1567 |
|
# Construct the query. |
1568 |
|
my $query = $self->Get($objectNames, $filterClause, $parameterList); |
1569 |
|
# Create the result list. |
1570 |
|
my @retVal = (); |
1571 |
|
# Loop through the records, adding the field values found to the result list. |
1572 |
|
while (my $row = $query->Fetch()) { |
1573 |
|
push @retVal, $row->Value($field); |
1574 |
} |
} |
1575 |
if (@joinWhere) { |
# Return the list created. |
1576 |
$command .= " WHERE " . join(' AND ', @joinWhere); |
return @retVal; |
1577 |
} |
} |
1578 |
# Add the sort or limit clause (if any) to the SELECT command. |
|
1579 |
if ($orderClause) { |
=head3 SpecialFields |
1580 |
$command .= " $orderClause"; |
|
1581 |
|
C<< my %specials = $erdb->SpecialFields($entityName); >> |
1582 |
|
|
1583 |
|
Return a hash mapping special fields in the specified entity to the value of their |
1584 |
|
C<special> attribute. This enables the subclass to get access to the special field |
1585 |
|
attributes without needed to plumb the internal ERDB data structures. |
1586 |
|
|
1587 |
|
=over 4 |
1588 |
|
|
1589 |
|
=item entityName |
1590 |
|
|
1591 |
|
Name of the entity whose special fields are desired. |
1592 |
|
|
1593 |
|
=item RETURN |
1594 |
|
|
1595 |
|
Returns a hash. The keys of the hash are the special field names, and the values |
1596 |
|
are the values from each special field's C<special> attribute. |
1597 |
|
|
1598 |
|
=back |
1599 |
|
|
1600 |
|
=cut |
1601 |
|
|
1602 |
|
sub SpecialFields { |
1603 |
|
# Get the parameters. |
1604 |
|
my ($self, $entityName) = @_; |
1605 |
|
# Declare the return variable. |
1606 |
|
my %retVal = (); |
1607 |
|
# Find the entity's data structure. |
1608 |
|
my $entityData = $self->{_metaData}->{Entities}->{$entityName}; |
1609 |
|
# Loop through its fields, adding each special field to the return hash. |
1610 |
|
my $fieldHash = $entityData->{Fields}; |
1611 |
|
for my $fieldName (keys %{$fieldHash}) { |
1612 |
|
my $fieldData = $fieldHash->{$fieldName}; |
1613 |
|
if (exists $fieldData->{special}) { |
1614 |
|
$retVal{$fieldName} = $fieldData->{special}; |
1615 |
} |
} |
1616 |
} |
} |
1617 |
Trace("SQL query: $command") if T(SQL => 4); |
# Return the result. |
1618 |
Trace("PARMS: '" . (join "', '", @params) . "'") if (T(SQL => 4) && (@params > 0)); |
return %retVal; |
|
my $sth = $dbh->prepare_command($command); |
|
|
# Execute it with the parameters bound in. |
|
|
$sth->execute(@params) || Confess("SELECT error" . $sth->errstr()); |
|
|
# Return the statement object. |
|
|
my $retVal = DBQuery::_new($self, $sth, @{$objectNames}); |
|
|
return $retVal; |
|
1619 |
} |
} |
1620 |
|
|
1621 |
=head3 Delete |
=head3 Delete |
1622 |
|
|
1623 |
C<< my $stats = $erdb->Delete($entityName, $objectID); >> |
C<< my $stats = $erdb->Delete($entityName, $objectID, %options); >> |
1624 |
|
|
1625 |
Delete an entity instance from the database. The instance is deleted along with all entity and |
Delete an entity instance from the database. The instance is deleted along with all entity and |
1626 |
relationship instances dependent on it. The idea of dependence here is recursive. An object is |
relationship instances dependent on it. The definition of I<dependence> is recursive. |
1627 |
always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many |
|
1628 |
relationship connected to a dependent entity or the "to" entity connected to a 1-to-many |
An object is always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many |
1629 |
|
relationship connected to a dependent entity or if it is the "to" entity connected to a 1-to-many |
1630 |
dependent relationship. |
dependent relationship. |
1631 |
|
|
1632 |
=over 4 |
=over 4 |
1640 |
ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>), |
ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>), |
1641 |
then it is presumed to by a LIKE pattern. |
then it is presumed to by a LIKE pattern. |
1642 |
|
|
1643 |
=item testFlag |
=item options |
1644 |
|
|
1645 |
If TRUE, the delete statements will be traced without being executed. |
A hash detailing the options for this delete operation. |
1646 |
|
|
1647 |
=item RETURN |
=item RETURN |
1648 |
|
|
1651 |
|
|
1652 |
=back |
=back |
1653 |
|
|
1654 |
|
The permissible options for this method are as follows. |
1655 |
|
|
1656 |
|
=over 4 |
1657 |
|
|
1658 |
|
=item testMode |
1659 |
|
|
1660 |
|
If TRUE, then the delete statements will be traced, but no changes will be made to the database. |
1661 |
|
|
1662 |
|
=item keepRoot |
1663 |
|
|
1664 |
|
If TRUE, then the entity instances will not be deleted, only the dependent records. |
1665 |
|
|
1666 |
|
=back |
1667 |
|
|
1668 |
=cut |
=cut |
1669 |
#: Return Type $%; |
#: Return Type $%; |
1670 |
sub Delete { |
sub Delete { |
1671 |
# Get the parameters. |
# Get the parameters. |
1672 |
my ($self, $entityName, $objectID, $testFlag) = @_; |
my ($self, $entityName, $objectID, %options) = @_; |
1673 |
# Declare the return variable. |
# Declare the return variable. |
1674 |
my $retVal = Stats->new(); |
my $retVal = Stats->new(); |
1675 |
# Get the DBKernel object. |
# Get the DBKernel object. |
1686 |
# FROM-relationships and entities. |
# FROM-relationships and entities. |
1687 |
my @fromPathList = (); |
my @fromPathList = (); |
1688 |
my @toPathList = (); |
my @toPathList = (); |
1689 |
# This final hash is used to remember what work still needs to be done. We push paths |
# This final list is used to remember what work still needs to be done. We push paths |
1690 |
# onto the list, then pop them off to extend the paths. We prime it with the starting |
# onto the list, then pop them off to extend the paths. We prime it with the starting |
1691 |
# point. Note that we will work hard to insure that the last item on a path in the |
# point. Note that we will work hard to insure that the last item on a path in the |
1692 |
# TODO list is always an entity. |
# to-do list is always an entity. |
1693 |
my @todoList = ([$entityName]); |
my @todoList = ([$entityName]); |
1694 |
while (@todoList) { |
while (@todoList) { |
1695 |
# Get the current path. |
# Get the current path. |
1697 |
# Copy it into a list. |
# Copy it into a list. |
1698 |
my @stackedPath = @{$current}; |
my @stackedPath = @{$current}; |
1699 |
# Pull off the last item on the path. It will always be an entity. |
# Pull off the last item on the path. It will always be an entity. |
1700 |
my $entityName = pop @stackedPath; |
my $myEntityName = pop @stackedPath; |
1701 |
# Add it to the alreadyFound list. |
# Add it to the alreadyFound list. |
1702 |
$alreadyFound{$entityName} = 1; |
$alreadyFound{$myEntityName} = 1; |
1703 |
|
# Figure out if we need to delete this entity. |
1704 |
|
if ($myEntityName ne $entityName || ! $options{keepRoot}) { |
1705 |
# Get the entity data. |
# Get the entity data. |
1706 |
my $entityData = $self->_GetStructure($entityName); |
my $entityData = $self->_GetStructure($myEntityName); |
1707 |
# The first task is to loop through the entity's relation. A DELETE command will |
# Loop through the entity's relations. A DELETE command will be needed for each of them. |
|
# be needed for each of them. |
|
1708 |
my $relations = $entityData->{Relations}; |
my $relations = $entityData->{Relations}; |
1709 |
for my $relation (keys %{$relations}) { |
for my $relation (keys %{$relations}) { |
1710 |
my @augmentedList = (@stackedPath, $relation); |
my @augmentedList = (@stackedPath, $relation); |
1711 |
push @fromPathList, \@augmentedList; |
push @fromPathList, \@augmentedList; |
1712 |
} |
} |
1713 |
|
} |
1714 |
# Now we need to look for relationships connected to this entity. |
# Now we need to look for relationships connected to this entity. |
1715 |
my $relationshipList = $self->{_metaData}->{Relationships}; |
my $relationshipList = $self->{_metaData}->{Relationships}; |
1716 |
for my $relationshipName (keys %{$relationshipList}) { |
for my $relationshipName (keys %{$relationshipList}) { |
1717 |
my $relationship = $relationshipList->{$relationshipName}; |
my $relationship = $relationshipList->{$relationshipName}; |
1718 |
# Check the FROM field. We're only interested if it's us. |
# Check the FROM field. We're only interested if it's us. |
1719 |
if ($relationship->{from} eq $entityName) { |
if ($relationship->{from} eq $myEntityName) { |
1720 |
# Add the path to this relationship. |
# Add the path to this relationship. |
1721 |
my @augmentedList = (@stackedPath, $entityName, $relationshipName); |
my @augmentedList = (@stackedPath, $myEntityName, $relationshipName); |
1722 |
push @fromPathList, \@augmentedList; |
push @fromPathList, \@augmentedList; |
1723 |
# Check the arity. If it's MM we're done. If it's 1M |
# Check the arity. If it's MM we're done. If it's 1M |
1724 |
# and the target hasn't been seen yet, we want to |
# and the target hasn't been seen yet, we want to |
1730 |
# the current entity, so we need to stack it. |
# the current entity, so we need to stack it. |
1731 |
my @stackList = (@augmentedList, $toEntity); |
my @stackList = (@augmentedList, $toEntity); |
1732 |
push @fromPathList, \@stackList; |
push @fromPathList, \@stackList; |
1733 |
|
} else { |
1734 |
|
Trace("$toEntity ignored because it occurred previously.") if T(4); |
1735 |
} |
} |
1736 |
} |
} |
1737 |
} |
} |
1738 |
# Now check the TO field. In this case only the relationship needs |
# Now check the TO field. In this case only the relationship needs |
1739 |
# deletion. |
# deletion. |
1740 |
if ($relationship->{to} eq $entityName) { |
if ($relationship->{to} eq $myEntityName) { |
1741 |
my @augmentedList = (@stackedPath, $entityName, $relationshipName); |
my @augmentedList = (@stackedPath, $myEntityName, $relationshipName); |
1742 |
push @toPathList, \@augmentedList; |
push @toPathList, \@augmentedList; |
1743 |
} |
} |
1744 |
} |
} |
1745 |
} |
} |
1746 |
# Create the first qualifier for the WHERE clause. This selects the |
# Create the first qualifier for the WHERE clause. This selects the |
1747 |
# keys of the primary entity records to be deleted. When we're deleting |
# keys of the primary entity records to be deleted. When we're deleting |
1748 |
# from a dependent table, we construct a join page from the first qualifier |
# from a dependent table, we construct a join path from the first qualifier |
1749 |
# to the table containing the dependent records to delete. |
# to the table containing the dependent records to delete. |
1750 |
my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?"); |
my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?"); |
1751 |
# We need to make two passes. The first is through the to-list, and |
# We need to make two passes. The first is through the to-list, and |
1757 |
for my $keyName ('to_link', 'from_link') { |
for my $keyName ('to_link', 'from_link') { |
1758 |
# Get the list for this key. |
# Get the list for this key. |
1759 |
my @pathList = @{$stackList{$keyName}}; |
my @pathList = @{$stackList{$keyName}}; |
1760 |
|
Trace(scalar(@pathList) . " entries in path list for $keyName.") if T(3); |
1761 |
# Loop through this list. |
# Loop through this list. |
1762 |
while (my $path = pop @pathList) { |
while (my $path = pop @pathList) { |
1763 |
# Get the table whose rows are to be deleted. |
# Get the table whose rows are to be deleted. |
1764 |
my @pathTables = @{$path}; |
my @pathTables = @{$path}; |
1765 |
# Start the DELETE statement. |
# Start the DELETE statement. We need to call DBKernel because the |
1766 |
|
# syntax of a DELETE-USING varies among DBMSs. |
1767 |
my $target = $pathTables[$#pathTables]; |
my $target = $pathTables[$#pathTables]; |
1768 |
my $stmt = "DELETE FROM $target"; |
my $stmt = $db->SetUsing(@pathTables); |
|
# If there's more than just the one table, we need a USING clause. |
|
|
if (@pathTables > 1) { |
|
|
$stmt .= " USING " . join(", ", @pathTables[0 .. ($#pathTables - 1)]); |
|
|
} |
|
1769 |
# Now start the WHERE. The first thing is the ID field from the starting table. That |
# Now start the WHERE. The first thing is the ID field from the starting table. That |
1770 |
# starting table will either be the entity relation or one of the entity's |
# starting table will either be the entity relation or one of the entity's |
1771 |
# sub-relations. |
# sub-relations. |
1775 |
# Connect the current relationship to the preceding entity. |
# Connect the current relationship to the preceding entity. |
1776 |
my ($entity, $rel) = @pathTables[$i-1,$i]; |
my ($entity, $rel) = @pathTables[$i-1,$i]; |
1777 |
# The style of connection depends on the direction of the relationship. |
# The style of connection depends on the direction of the relationship. |
1778 |
$stmt .= " AND $entity.id = $rel.from_link"; |
$stmt .= " AND $entity.id = $rel.$keyName"; |
1779 |
if ($i + 1 <= $#pathTables) { |
if ($i + 1 <= $#pathTables) { |
1780 |
# Here there's a next entity, so connect that to the relationship's |
# Here there's a next entity, so connect that to the relationship's |
1781 |
# to-link. |
# to-link. |
1782 |
my $entity2 = $pathTables[$i+1]; |
my $entity2 = $pathTables[$i+1]; |
1783 |
$stmt .= " AND $rel.$keyName = $entity2.id"; |
$stmt .= " AND $rel.to_link = $entity2.id"; |
1784 |
} |
} |
1785 |
} |
} |
1786 |
# Now we have our desired DELETE statement. |
# Now we have our desired DELETE statement. |
1787 |
if ($testFlag) { |
if ($options{testMode}) { |
1788 |
# Here the user wants to trace without executing. |
# Here the user wants to trace without executing. |
1789 |
Trace($stmt) if T(0); |
Trace($stmt) if T(0); |
1790 |
} else { |
} else { |
1791 |
# Here we can delete. Note that the SQL method dies with a confessing |
# Here we can delete. Note that the SQL method dies with a confession |
1792 |
# if an error occurs, so we just go ahead and do it. |
# if an error occurs, so we just go ahead and do it. |
1793 |
Trace("Executing delete: $stmt") if T(3); |
Trace("Executing delete from $target using '$objectID'.") if T(3); |
1794 |
my $rv = $db->SQL($stmt, 0, [$objectID]); |
my $rv = $db->SQL($stmt, 0, $objectID); |
1795 |
# Accumulate the statistics for this delete. The only rows deleted |
# Accumulate the statistics for this delete. The only rows deleted |
1796 |
# are from the target table, so we use its name to record the |
# are from the target table, so we use its name to record the |
1797 |
# statistic. |
# statistic. |
1803 |
return $retVal; |
return $retVal; |
1804 |
} |
} |
1805 |
|
|
1806 |
=head3 GetList |
=head3 Disconnect |
|
|
|
|
C<< my @dbObjects = $erdb->GetList(\@objectNames, $filterClause, $param1, $param2, ..., $paramN); >> |
|
1807 |
|
|
1808 |
Return a list of object descriptors for the specified objects as determined by the |
C<< $erdb->Disconnect($relationshipName, $originEntityName, $originEntityID); >> |
|
specified filter clause. |
|
1809 |
|
|
1810 |
This method is essentially the same as L</Get> except it returns a list of objects rather |
Disconnect an entity instance from all the objects to which it is related. This |
1811 |
than a query object that can be used to get the results one record at a time. |
will delete each relationship instance that connects to the specified entity. |
1812 |
|
|
1813 |
=over 4 |
=over 4 |
1814 |
|
|
1815 |
=item objectNames |
=item relationshipName |
|
|
|
|
List containing the names of the entity and relationship objects to be retrieved. |
|
|
|
|
|
=item filterClause |
|
|
|
|
|
WHERE clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can |
|
|
be parameterized with parameter markers (C<?>). Each field used in the WHERE clause must be |
|
|
specified in the standard form B<I<objectName>(I<fieldName>)>. Any parameters specified |
|
|
in the filter clause should be added to the parameter list as additional parameters. The |
|
|
fields in a filter clause can come from primary entity relations, relationship relations, |
|
|
or secondary entity relations; however, all of the entities and relationships involved must |
|
|
be included in the list of object names. |
|
|
|
|
|
The filter clause can also specify a sort order. To do this, simply follow the filter string |
|
|
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
|
|
particular genus and sorts them by species name. |
|
|
|
|
|
C<< "Genome(genus) = ? ORDER BY Genome(species)" >> |
|
1816 |
|
|
1817 |
The rules for field references in a sort order are the same as those for field references in the |
Name of the relationship whose instances are to be deleted. |
|
filter clause in general; however, odd things may happen if a sort field is from a secondary |
|
|
relation. |
|
1818 |
|
|
1819 |
=item param1, param2, ..., paramN |
=item originEntityName |
1820 |
|
|
1821 |
Parameter values to be substituted into the filter clause. |
Name of the entity that is to be disconnected. |
1822 |
|
|
1823 |
=item RETURN |
=item originEntityID |
1824 |
|
|
1825 |
Returns a list of B<DBObject>s that satisfy the query conditions. |
ID of the entity that is to be disconnected. |
1826 |
|
|
1827 |
=back |
=back |
1828 |
|
|
1829 |
=cut |
=cut |
1830 |
#: Return Type @% |
|
1831 |
sub GetList { |
sub Disconnect { |
1832 |
# Get the parameters. |
# Get the parameters. |
1833 |
my ($self, $objectNames, $filterClause, @params) = @_; |
my ($self, $relationshipName, $originEntityName, $originEntityID) = @_; |
1834 |
# Declare the return variable. |
# Get the relationship descriptor. |
1835 |
my @retVal = (); |
my $structure = $self->_GetStructure($relationshipName); |
1836 |
# Perform the query. |
# Insure we have a relationship. |
1837 |
my $query = $self->Get($objectNames, $filterClause, @params); |
if (! exists $structure->{from}) { |
1838 |
# Loop through the results. |
Confess("$relationshipName is not a relationship in the database."); |
1839 |
while (my $object = $query->Fetch) { |
} else { |
1840 |
push @retVal, $object; |
# Get the database handle. |
1841 |
|
my $dbh = $self->{_dbh}; |
1842 |
|
# We'll set this value to 1 if we find our entity. |
1843 |
|
my $found = 0; |
1844 |
|
# Loop through the ends of the relationship. |
1845 |
|
for my $dir ('from', 'to') { |
1846 |
|
if ($structure->{$dir} eq $originEntityName) { |
1847 |
|
# Delete all relationship instances on this side of the entity instance. |
1848 |
|
Trace("Disconnecting in $dir direction with ID \"$originEntityID\"."); |
1849 |
|
$dbh->SQL("DELETE FROM $relationshipName WHERE ${dir}_link = ?", 0, $originEntityID); |
1850 |
|
$found = 1; |
1851 |
|
} |
1852 |
|
} |
1853 |
|
# Insure we found the entity on at least one end. |
1854 |
|
if (! $found) { |
1855 |
|
Confess("Entity \"$originEntityName\" does not use $relationshipName."); |
1856 |
|
} |
1857 |
} |
} |
|
# Return the result. |
|
|
return @retVal; |
|
1858 |
} |
} |
1859 |
|
|
1860 |
=head3 ComputeObjectSentence |
=head3 DeleteRow |
1861 |
|
|
1862 |
C<< my $sentence = $erdb->ComputeObjectSentence($objectName); >> |
C<< $erdb->DeleteRow($relationshipName, $fromLink, $toLink, \%values); >> |
1863 |
|
|
1864 |
Check an object name, and if it is a relationship convert it to a relationship sentence. |
Delete a row from a relationship. In most cases, only the from-link and to-link are |
1865 |
|
needed; however, for relationships with intersection data values can be specified |
1866 |
|
for the other fields using a hash. |
1867 |
|
|
1868 |
=over 4 |
=over 4 |
1869 |
|
|
1870 |
=item objectName |
=item relationshipName |
1871 |
|
|
1872 |
Name of the entity or relationship. |
Name of the relationship from which the row is to be deleted. |
1873 |
|
|
1874 |
=item RETURN |
=item fromLink |
1875 |
|
|
1876 |
Returns a string containing the entity name or a relationship sentence. |
ID of the entity instance in the From direction. |
1877 |
|
|
1878 |
|
=item toLink |
1879 |
|
|
1880 |
|
ID of the entity instance in the To direction. |
1881 |
|
|
1882 |
|
=item values |
1883 |
|
|
1884 |
|
Reference to a hash of other values to be used for filtering the delete. |
1885 |
|
|
1886 |
=back |
=back |
1887 |
|
|
1888 |
=cut |
=cut |
1889 |
|
|
1890 |
sub ComputeObjectSentence { |
sub DeleteRow { |
1891 |
# Get the parameters. |
# Get the parameters. |
1892 |
my ($self, $objectName) = @_; |
my ($self, $relationshipName, $fromLink, $toLink, $values) = @_; |
1893 |
# Set the default return value. |
# Create a hash of all the filter information. |
1894 |
my $retVal = $objectName; |
my %filter = ('from-link' => $fromLink, 'to-link' => $toLink); |
1895 |
# Look for the object as a relationship. |
if (defined $values) { |
1896 |
my $relTable = $self->{_metaData}->{Relationships}; |
for my $key (keys %{$values}) { |
1897 |
if (exists $relTable->{$objectName}) { |
$filter{$key} = $values->{$key}; |
|
# Get the relationship sentence. |
|
|
$retVal = _ComputeRelationshipSentence($objectName, $relTable->{$objectName}); |
|
1898 |
} |
} |
1899 |
# Return the result. |
} |
1900 |
return $retVal; |
# Build an SQL statement out of the hash. |
1901 |
|
my @filters = (); |
1902 |
|
my @parms = (); |
1903 |
|
for my $key (keys %filter) { |
1904 |
|
push @filters, _FixName($key) . " = ?"; |
1905 |
|
push @parms, $filter{$key}; |
1906 |
|
} |
1907 |
|
Trace("Parms for delete row are " . join(", ", map { "\"$_\"" } @parms) . ".") if T(SQL => 4); |
1908 |
|
my $command = "DELETE FROM $relationshipName WHERE " . |
1909 |
|
join(" AND ", @filters); |
1910 |
|
# Execute it. |
1911 |
|
my $dbh = $self->{_dbh}; |
1912 |
|
$dbh->SQL($command, undef, @parms); |
1913 |
} |
} |
1914 |
|
|
1915 |
=head3 DumpRelations |
=head3 SortNeeded |
1916 |
|
|
1917 |
C<< $erdb->DumpRelations($outputDirectory); >> |
C<< my $parms = $erdb->SortNeeded($relationName); >> |
1918 |
|
|
1919 |
Write the contents of all the relations to tab-delimited files in the specified directory. |
Return the pipe command for the sort that should be applied to the specified |
1920 |
Each file will have the same name as the relation dumped, with an extension of DTX. |
relation when creating the load file. |
1921 |
|
|
1922 |
=over 4 |
For example, if the load file should be sorted ascending by the first |
1923 |
|
field, this method would return |
1924 |
|
|
1925 |
=item outputDirectory |
sort -k1 -t"\t" |
1926 |
|
|
1927 |
Name of the directory into which the relation files should be dumped. |
If the first field is numeric, the method would return |
1928 |
|
|
1929 |
|
sort -k1n -t"\t" |
1930 |
|
|
1931 |
|
Unfortunately, due to a bug in the C<sort> command, we cannot eliminate duplicate |
1932 |
|
keys using a sort. |
1933 |
|
|
1934 |
|
=over 4 |
1935 |
|
|
1936 |
|
=item relationName |
1937 |
|
|
1938 |
|
Name of the relation to be examined. |
1939 |
|
|
1940 |
|
=item |
1941 |
|
|
1942 |
|
Returns the sort command to use for sorting the relation, suitable for piping. |
1943 |
|
|
1944 |
|
=back |
1945 |
|
|
1946 |
|
=cut |
1947 |
|
#: Return Type $; |
1948 |
|
sub SortNeeded { |
1949 |
|
# Get the parameters. |
1950 |
|
my ($self, $relationName) = @_; |
1951 |
|
# Declare a descriptor to hold the names of the key fields. |
1952 |
|
my @keyNames = (); |
1953 |
|
# Get the relation structure. |
1954 |
|
my $relationData = $self->_FindRelation($relationName); |
1955 |
|
# Find out if the relation is a primary entity relation, |
1956 |
|
# a relationship relation, or a secondary entity relation. |
1957 |
|
my $entityTable = $self->{_metaData}->{Entities}; |
1958 |
|
my $relationshipTable = $self->{_metaData}->{Relationships}; |
1959 |
|
if (exists $entityTable->{$relationName}) { |
1960 |
|
# Here we have a primary entity relation. |
1961 |
|
push @keyNames, "id"; |
1962 |
|
} elsif (exists $relationshipTable->{$relationName}) { |
1963 |
|
# Here we have a relationship. We sort using the FROM index. |
1964 |
|
my $relationshipData = $relationshipTable->{$relationName}; |
1965 |
|
my $index = $relationData->{Indexes}->{idxFrom}; |
1966 |
|
push @keyNames, @{$index->{IndexFields}}; |
1967 |
|
} else { |
1968 |
|
# Here we have a secondary entity relation, so we have a sort on the ID field. |
1969 |
|
push @keyNames, "id"; |
1970 |
|
} |
1971 |
|
# Now we parse the key names into sort parameters. First, we prime the return |
1972 |
|
# string. |
1973 |
|
my $retVal = "sort -t\"\t\" "; |
1974 |
|
# Get the relation's field list. |
1975 |
|
my @fields = @{$relationData->{Fields}}; |
1976 |
|
# Loop through the keys. |
1977 |
|
for my $keyData (@keyNames) { |
1978 |
|
# Get the key and the ordering. |
1979 |
|
my ($keyName, $ordering); |
1980 |
|
if ($keyData =~ /^([^ ]+) DESC/) { |
1981 |
|
($keyName, $ordering) = ($1, "descending"); |
1982 |
|
} else { |
1983 |
|
($keyName, $ordering) = ($keyData, "ascending"); |
1984 |
|
} |
1985 |
|
# Find the key's position and type. |
1986 |
|
my $fieldSpec; |
1987 |
|
for (my $i = 0; $i <= $#fields && ! $fieldSpec; $i++) { |
1988 |
|
my $thisField = $fields[$i]; |
1989 |
|
if ($thisField->{name} eq $keyName) { |
1990 |
|
# Get the sort modifier for this field type. The modifier |
1991 |
|
# decides whether we're using a character, numeric, or |
1992 |
|
# floating-point sort. |
1993 |
|
my $modifier = $TypeTable{$thisField->{type}}->{sort}; |
1994 |
|
# If the index is descending for this field, denote we want |
1995 |
|
# to reverse the sort order on this field. |
1996 |
|
if ($ordering eq 'descending') { |
1997 |
|
$modifier .= "r"; |
1998 |
|
} |
1999 |
|
# Store the position and modifier into the field spec, which |
2000 |
|
# will stop the inner loop. Note that the field number is |
2001 |
|
# 1-based in the sort command, so we have to increment the |
2002 |
|
# index. |
2003 |
|
$fieldSpec = ($i + 1) . $modifier; |
2004 |
|
} |
2005 |
|
} |
2006 |
|
# Add this field to the sort command. |
2007 |
|
$retVal .= " -k$fieldSpec"; |
2008 |
|
} |
2009 |
|
# Return the result. |
2010 |
|
return $retVal; |
2011 |
|
} |
2012 |
|
|
2013 |
|
=head3 GetList |
2014 |
|
|
2015 |
|
C<< my @dbObjects = $erdb->GetList(\@objectNames, $filterClause, \@params); >> |
2016 |
|
|
2017 |
|
Return a list of object descriptors for the specified objects as determined by the |
2018 |
|
specified filter clause. |
2019 |
|
|
2020 |
|
This method is essentially the same as L</Get> except it returns a list of objects rather |
2021 |
|
than a query object that can be used to get the results one record at a time. |
2022 |
|
|
2023 |
|
=over 4 |
2024 |
|
|
2025 |
|
=item objectNames |
2026 |
|
|
2027 |
|
List containing the names of the entity and relationship objects to be retrieved. |
2028 |
|
|
2029 |
|
=item filterClause |
2030 |
|
|
2031 |
|
WHERE clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can |
2032 |
|
be parameterized with parameter markers (C<?>). Each field used in the WHERE clause must be |
2033 |
|
specified in the standard form B<I<objectName>(I<fieldName>)>. Any parameters specified |
2034 |
|
in the filter clause should be added to the parameter list as additional parameters. The |
2035 |
|
fields in a filter clause can come from primary entity relations, relationship relations, |
2036 |
|
or secondary entity relations; however, all of the entities and relationships involved must |
2037 |
|
be included in the list of object names. |
2038 |
|
|
2039 |
|
The filter clause can also specify a sort order. To do this, simply follow the filter string |
2040 |
|
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
2041 |
|
particular genus and sorts them by species name. |
2042 |
|
|
2043 |
|
C<< "Genome(genus) = ? ORDER BY Genome(species)" >> |
2044 |
|
|
2045 |
|
The rules for field references in a sort order are the same as those for field references in the |
2046 |
|
filter clause in general; however, odd things may happen if a sort field is from a secondary |
2047 |
|
relation. |
2048 |
|
|
2049 |
|
=item params |
2050 |
|
|
2051 |
|
Reference to a list of parameter values to be substituted into the filter clause. |
2052 |
|
|
2053 |
|
=item RETURN |
2054 |
|
|
2055 |
|
Returns a list of B<DBObject>s that satisfy the query conditions. |
2056 |
|
|
2057 |
|
=back |
2058 |
|
|
2059 |
|
=cut |
2060 |
|
#: Return Type @% |
2061 |
|
sub GetList { |
2062 |
|
# Get the parameters. |
2063 |
|
my ($self, $objectNames, $filterClause, $params) = @_; |
2064 |
|
# Declare the return variable. |
2065 |
|
my @retVal = (); |
2066 |
|
# Perform the query. |
2067 |
|
my $query = $self->Get($objectNames, $filterClause, $params); |
2068 |
|
# Loop through the results. |
2069 |
|
while (my $object = $query->Fetch) { |
2070 |
|
push @retVal, $object; |
2071 |
|
} |
2072 |
|
# Return the result. |
2073 |
|
return @retVal; |
2074 |
|
} |
2075 |
|
|
2076 |
|
=head3 GetCount |
2077 |
|
|
2078 |
|
C<< my $count = $erdb->GetCount(\@objectNames, $filter, \@params); >> |
2079 |
|
|
2080 |
|
Return the number of rows found by a specified query. This method would |
2081 |
|
normally be used to count the records in a single table. For example, in a |
2082 |
|
genetics database |
2083 |
|
|
2084 |
|
my $count = $erdb->GetCount(['Genome'], 'Genome(genus-species) LIKE ?', ['homo %']); |
2085 |
|
|
2086 |
|
would return the number of genomes for the genus I<homo>. It is conceivable, however, |
2087 |
|
to use it to return records based on a join. For example, |
2088 |
|
|
2089 |
|
my $count = $erdb->GetCount(['HasFeature', 'Genome'], 'Genome(genus-species) LIKE ?', |
2090 |
|
['homo %']); |
2091 |
|
|
2092 |
|
would return the number of features for genomes in the genus I<homo>. Note that |
2093 |
|
only the rows from the first table are counted. If the above command were |
2094 |
|
|
2095 |
|
my $count = $erdb->GetCount(['Genome', 'Feature'], 'Genome(genus-species) LIKE ?', |
2096 |
|
['homo %']); |
2097 |
|
|
2098 |
|
it would return the number of genomes, not the number of genome/feature pairs. |
2099 |
|
|
2100 |
|
=over 4 |
2101 |
|
|
2102 |
|
=item objectNames |
2103 |
|
|
2104 |
|
Reference to a list of the objects (entities and relationships) included in the |
2105 |
|
query. |
2106 |
|
|
2107 |
|
=item filter |
2108 |
|
|
2109 |
|
A filter clause for restricting the query. The rules are the same as for the L</Get> |
2110 |
|
method. |
2111 |
|
|
2112 |
|
=item params |
2113 |
|
|
2114 |
|
Reference to a list of the parameter values to be substituted for the parameter marks |
2115 |
|
in the filter. |
2116 |
|
|
2117 |
|
=item RETURN |
2118 |
|
|
2119 |
|
Returns a count of the number of records in the first table that would satisfy |
2120 |
|
the query. |
2121 |
|
|
2122 |
|
=back |
2123 |
|
|
2124 |
|
=cut |
2125 |
|
|
2126 |
|
sub GetCount { |
2127 |
|
# Get the parameters. |
2128 |
|
my ($self, $objectNames, $filter, $params) = @_; |
2129 |
|
# Insure the params argument is an array reference if the caller left it off. |
2130 |
|
if (! defined($params)) { |
2131 |
|
$params = []; |
2132 |
|
} |
2133 |
|
# Declare the return variable. |
2134 |
|
my $retVal; |
2135 |
|
# Find out if we're counting an entity or a relationship. |
2136 |
|
my $countedField; |
2137 |
|
if ($self->IsEntity($objectNames->[0])) { |
2138 |
|
$countedField = "id"; |
2139 |
|
} else { |
2140 |
|
# For a relationship we count the to-link because it's usually more |
2141 |
|
# numerous. Note we're automatically converting to the SQL form |
2142 |
|
# of the field name (to_link vs. to-link). |
2143 |
|
$countedField = "to_link"; |
2144 |
|
} |
2145 |
|
# Create the SQL command suffix to get the desired records. |
2146 |
|
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = $self->_SetupSQL($objectNames, |
2147 |
|
$filter); |
2148 |
|
# Prefix it with text telling it we want a record count. |
2149 |
|
my $firstObject = $mappedNameListRef->[0]; |
2150 |
|
my $command = "SELECT COUNT($firstObject.$countedField) $suffix"; |
2151 |
|
# Prepare and execute the command. |
2152 |
|
my $sth = $self->_GetStatementHandle($command, $params); |
2153 |
|
# Get the count value. |
2154 |
|
($retVal) = $sth->fetchrow_array(); |
2155 |
|
# Check for a problem. |
2156 |
|
if (! defined($retVal)) { |
2157 |
|
if ($sth->err) { |
2158 |
|
# Here we had an SQL error. |
2159 |
|
Confess("Error retrieving row count: " . $sth->errstr()); |
2160 |
|
} else { |
2161 |
|
# Here we have no result. |
2162 |
|
Confess("No result attempting to retrieve row count."); |
2163 |
|
} |
2164 |
|
} |
2165 |
|
# Return the result. |
2166 |
|
return $retVal; |
2167 |
|
} |
2168 |
|
|
2169 |
|
=head3 ComputeObjectSentence |
2170 |
|
|
2171 |
|
C<< my $sentence = $erdb->ComputeObjectSentence($objectName); >> |
2172 |
|
|
2173 |
|
Check an object name, and if it is a relationship convert it to a relationship sentence. |
2174 |
|
|
2175 |
|
=over 4 |
2176 |
|
|
2177 |
|
=item objectName |
2178 |
|
|
2179 |
|
Name of the entity or relationship. |
2180 |
|
|
2181 |
|
=item RETURN |
2182 |
|
|
2183 |
|
Returns a string containing the entity name or a relationship sentence. |
2184 |
|
|
2185 |
|
=back |
2186 |
|
|
2187 |
|
=cut |
2188 |
|
|
2189 |
|
sub ComputeObjectSentence { |
2190 |
|
# Get the parameters. |
2191 |
|
my ($self, $objectName) = @_; |
2192 |
|
# Set the default return value. |
2193 |
|
my $retVal = $objectName; |
2194 |
|
# Look for the object as a relationship. |
2195 |
|
my $relTable = $self->{_metaData}->{Relationships}; |
2196 |
|
if (exists $relTable->{$objectName}) { |
2197 |
|
# Get the relationship sentence. |
2198 |
|
$retVal = _ComputeRelationshipSentence($objectName, $relTable->{$objectName}); |
2199 |
|
} |
2200 |
|
# Return the result. |
2201 |
|
return $retVal; |
2202 |
|
} |
2203 |
|
|
2204 |
|
=head3 DumpRelations |
2205 |
|
|
2206 |
|
C<< $erdb->DumpRelations($outputDirectory); >> |
2207 |
|
|
2208 |
|
Write the contents of all the relations to tab-delimited files in the specified directory. |
2209 |
|
Each file will have the same name as the relation dumped, with an extension of DTX. |
2210 |
|
|
2211 |
|
=over 4 |
2212 |
|
|
2213 |
|
=item outputDirectory |
2214 |
|
|
2215 |
|
Name of the directory into which the relation files should be dumped. |
2216 |
|
|
2217 |
=back |
=back |
2218 |
|
|
2243 |
} |
} |
2244 |
} |
} |
2245 |
|
|
2246 |
|
=head3 InsertValue |
2247 |
|
|
2248 |
|
C<< $erdb->InsertValue($entityID, $fieldName, $value); >> |
2249 |
|
|
2250 |
|
This method will insert a new value into the database. The value must be one |
2251 |
|
associated with a secondary relation, since primary values cannot be inserted: |
2252 |
|
they occur exactly once. Secondary values, on the other hand, can be missing |
2253 |
|
or multiply-occurring. |
2254 |
|
|
2255 |
|
=over 4 |
2256 |
|
|
2257 |
|
=item entityID |
2258 |
|
|
2259 |
|
ID of the object that is to receive the new value. |
2260 |
|
|
2261 |
|
=item fieldName |
2262 |
|
|
2263 |
|
Field name for the new value-- this includes the entity name, since |
2264 |
|
field names are of the format I<objectName>C<(>I<fieldName>C<)>. |
2265 |
|
|
2266 |
|
=item value |
2267 |
|
|
2268 |
|
New value to be put in the field. |
2269 |
|
|
2270 |
|
=back |
2271 |
|
|
2272 |
|
=cut |
2273 |
|
|
2274 |
|
sub InsertValue { |
2275 |
|
# Get the parameters. |
2276 |
|
my ($self, $entityID, $fieldName, $value) = @_; |
2277 |
|
# Parse the entity name and the real field name. |
2278 |
|
if ($fieldName =~ /^([^(]+)\(([^)]+)\)/) { |
2279 |
|
my $entityName = $1; |
2280 |
|
my $fieldTitle = $2; |
2281 |
|
# Get its descriptor. |
2282 |
|
if (!$self->IsEntity($entityName)) { |
2283 |
|
Confess("$entityName is not a valid entity."); |
2284 |
|
} else { |
2285 |
|
my $entityData = $self->{_metaData}->{Entities}->{$entityName}; |
2286 |
|
# Find the relation containing this field. |
2287 |
|
my $fieldHash = $entityData->{Fields}; |
2288 |
|
if (! exists $fieldHash->{$fieldTitle}) { |
2289 |
|
Confess("$fieldTitle not found in $entityName."); |
2290 |
|
} else { |
2291 |
|
my $relation = $fieldHash->{$fieldTitle}->{relation}; |
2292 |
|
if ($relation eq $entityName) { |
2293 |
|
Confess("Cannot do InsertValue on primary field $fieldTitle of $entityName."); |
2294 |
|
} else { |
2295 |
|
# Now we can create an INSERT statement. |
2296 |
|
my $dbh = $self->{_dbh}; |
2297 |
|
my $fixedName = _FixName($fieldTitle); |
2298 |
|
my $statement = "INSERT INTO $relation (id, $fixedName) VALUES(?, ?)"; |
2299 |
|
# Execute the command. |
2300 |
|
$dbh->SQL($statement, 0, $entityID, $value); |
2301 |
|
} |
2302 |
|
} |
2303 |
|
} |
2304 |
|
} else { |
2305 |
|
Confess("$fieldName is not a valid field name."); |
2306 |
|
} |
2307 |
|
} |
2308 |
|
|
2309 |
=head3 InsertObject |
=head3 InsertObject |
2310 |
|
|
2311 |
C<< my $ok = $erdb->InsertObject($objectType, \%fieldHash); >> |
C<< $erdb->InsertObject($objectType, \%fieldHash); >> |
2312 |
|
|
2313 |
Insert an object into the database. The object is defined by a type name and then a hash |
Insert an object into the database. The object is defined by a type name and then a hash |
2314 |
of field names to values. Field values in the primary relation are represented by scalars. |
of field names to values. Field values in the primary relation are represented by scalars. |
2322 |
The next statement inserts a C<HasProperty> relationship between feature C<fig|158879.1.peg.1> and |
The next statement inserts a C<HasProperty> relationship between feature C<fig|158879.1.peg.1> and |
2323 |
property C<4> with an evidence URL of C<http://seedu.uchicago.edu/query.cgi?article_id=142>. |
property C<4> with an evidence URL of C<http://seedu.uchicago.edu/query.cgi?article_id=142>. |
2324 |
|
|
2325 |
C<< $erdb->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence = 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); >> |
C<< $erdb->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence => 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); >> |
2326 |
|
|
2327 |
=over 4 |
=over 4 |
2328 |
|
|
2334 |
|
|
2335 |
Hash of field names to values. |
Hash of field names to values. |
2336 |
|
|
|
=item RETURN |
|
|
|
|
|
Returns 1 if successful, 0 if an error occurred. |
|
|
|
|
2337 |
=back |
=back |
2338 |
|
|
2339 |
=cut |
=cut |
2432 |
$retVal = $sth->execute(@parameterList); |
$retVal = $sth->execute(@parameterList); |
2433 |
if (!$retVal) { |
if (!$retVal) { |
2434 |
my $errorString = $sth->errstr(); |
my $errorString = $sth->errstr(); |
2435 |
Trace("Insert error: $errorString.") if T(0); |
Confess("Error inserting into $relationName: $errorString"); |
2436 |
} |
} |
2437 |
} |
} |
2438 |
} |
} |
2439 |
} |
} |
2440 |
# Return the success indicator. |
# Return a 1 for backward compatability. |
2441 |
return $retVal; |
return 1; |
2442 |
|
} |
2443 |
|
|
2444 |
|
=head3 UpdateEntity |
2445 |
|
|
2446 |
|
C<< $erdb->UpdateEntity($entityName, $id, \%fields); >> |
2447 |
|
|
2448 |
|
Update the values of an entity. This is an unprotected update, so it should only be |
2449 |
|
done if the database resides on a database server. |
2450 |
|
|
2451 |
|
=over 4 |
2452 |
|
|
2453 |
|
=item entityName |
2454 |
|
|
2455 |
|
Name of the entity to update. (This is the entity type.) |
2456 |
|
|
2457 |
|
=item id |
2458 |
|
|
2459 |
|
ID of the entity to update. If no entity exists with this ID, an error will be thrown. |
2460 |
|
|
2461 |
|
=item fields |
2462 |
|
|
2463 |
|
Reference to a hash mapping field names to their new values. All of the fields named |
2464 |
|
must be in the entity's primary relation, and they cannot any of them be the ID field. |
2465 |
|
|
2466 |
|
=back |
2467 |
|
|
2468 |
|
=cut |
2469 |
|
|
2470 |
|
sub UpdateEntity { |
2471 |
|
# Get the parameters. |
2472 |
|
my ($self, $entityName, $id, $fields) = @_; |
2473 |
|
# Get a list of the field names being updated. |
2474 |
|
my @fieldList = keys %{$fields}; |
2475 |
|
# Verify that the fields exist. |
2476 |
|
my $checker = $self->GetFieldTable($entityName); |
2477 |
|
for my $field (@fieldList) { |
2478 |
|
if ($field eq 'id') { |
2479 |
|
Confess("Cannot update the ID field for entity $entityName."); |
2480 |
|
} elsif ($checker->{$field}->{relation} ne $entityName) { |
2481 |
|
Confess("Cannot find $field in primary relation of $entityName."); |
2482 |
|
} |
2483 |
|
} |
2484 |
|
# Build the SQL statement. |
2485 |
|
my @sets = (); |
2486 |
|
my @valueList = (); |
2487 |
|
for my $field (@fieldList) { |
2488 |
|
push @sets, _FixName($field) . " = ?"; |
2489 |
|
push @valueList, $fields->{$field}; |
2490 |
|
} |
2491 |
|
my $command = "UPDATE $entityName SET " . join(", ", @sets) . " WHERE id = ?"; |
2492 |
|
# Add the ID to the list of binding values. |
2493 |
|
push @valueList, $id; |
2494 |
|
# Call SQL to do the work. |
2495 |
|
my $rows = $self->{_dbh}->SQL($command, 0, @valueList); |
2496 |
|
# Check for errors. |
2497 |
|
if ($rows == 0) { |
2498 |
|
Confess("Entity $id of type $entityName not found."); |
2499 |
|
} |
2500 |
} |
} |
2501 |
|
|
2502 |
=head3 LoadTable |
=head3 LoadTable |
2503 |
|
|
2504 |
C<< my %results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >> |
C<< my $results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >> |
2505 |
|
|
2506 |
Load data from a tab-delimited file into a specified table, optionally re-creating the table |
Load data from a tab-delimited file into a specified table, optionally re-creating the table |
2507 |
first. |
first. |
2568 |
}; |
}; |
2569 |
if (!defined $rv) { |
if (!defined $rv) { |
2570 |
$retVal->AddMessage($@) if ($@); |
$retVal->AddMessage($@) if ($@); |
2571 |
$retVal->AddMessage("Table load failed for $relationName using $fileName."); |
$retVal->AddMessage("Table load failed for $relationName using $fileName: " . $dbh->error_message); |
2572 |
Trace("Table load failed for $relationName.") if T(1); |
Trace("Table load failed for $relationName.") if T(1); |
2573 |
} else { |
} else { |
2574 |
# Here we successfully loaded the table. |
# Here we successfully loaded the table. |
2576 |
my $size = -s $fileName; |
my $size = -s $fileName; |
2577 |
Trace("$size bytes loaded into $relationName.") if T(2); |
Trace("$size bytes loaded into $relationName.") if T(2); |
2578 |
# If we're rebuilding, we need to create the table indexes. |
# If we're rebuilding, we need to create the table indexes. |
2579 |
if ($truncateFlag && ! $dbh->{_preIndex}) { |
if ($truncateFlag) { |
2580 |
|
# Indexes are created here for PostGres. For PostGres, indexes are |
2581 |
|
# best built at the end. For MySQL, the reverse is true. |
2582 |
|
if (! $dbh->{_preIndex}) { |
2583 |
eval { |
eval { |
2584 |
$self->CreateIndex($relationName); |
$self->CreateIndex($relationName); |
2585 |
}; |
}; |
2587 |
$retVal->AddMessage($@); |
$retVal->AddMessage($@); |
2588 |
} |
} |
2589 |
} |
} |
2590 |
|
# The full-text index (if any) is always built last, even for MySQL. |
2591 |
|
# First we need to see if this table has a full-text index. Only |
2592 |
|
# primary relations are allowed that privilege. |
2593 |
|
Trace("Checking for full-text index on $relationName.") if T(2); |
2594 |
|
if ($self->_IsPrimary($relationName)) { |
2595 |
|
$self->CreateSearchIndex($relationName); |
2596 |
|
} |
2597 |
|
} |
2598 |
} |
} |
2599 |
# Analyze the table to improve performance. |
# Analyze the table to improve performance. |
2600 |
|
Trace("Analyzing and compacting $relationName.") if T(3); |
2601 |
$dbh->vacuum_it($relationName); |
$dbh->vacuum_it($relationName); |
2602 |
|
Trace("$relationName load completed.") if T(3); |
2603 |
# Return the statistics. |
# Return the statistics. |
2604 |
return $retVal; |
return $retVal; |
2605 |
} |
} |
2606 |
|
|
2607 |
=head3 GenerateEntity |
=head3 CreateSearchIndex |
2608 |
|
|
2609 |
C<< my $fieldHash = $erdb->GenerateEntity($id, $type, \%values); >> |
C<< $erdb->CreateSearchIndex($objectName); >> |
2610 |
|
|
2611 |
Generate the data for a new entity instance. This method creates a field hash suitable for |
Check for a full-text search index on the specified entity or relationship object, and |
2612 |
passing as a parameter to L</InsertObject>. The ID is specified by the callr, but the rest |
if one is required, rebuild it. |
|
of the fields are generated using information in the database schema. |
|
|
|
|
|
Each data type has a default algorithm for generating random test data. This can be overridden |
|
|
by including a B<DataGen> element in the field. If this happens, the content of the element is |
|
|
executed as a PERL program in the context of this module. The element may make use of a C<$this> |
|
|
variable which contains the field hash as it has been built up to the current point. If any |
|
|
fields are dependent on other fields, the C<pass> attribute can be used to control the order |
|
|
in which the fields are generated. A field with a high data pass number will be generated after |
|
|
a field with a lower one. If any external values are needed, they should be passed in via the |
|
|
optional third parameter, which will be available to the data generation script under the name |
|
|
C<$value>. Several useful utility methods are provided for generating random values, including |
|
|
L</IntGen>, L</StringGen>, L</FloatGen>, and L</DateGen>. Note that dates are stored and generated |
|
|
in the form of a timestamp number rather than a string. |
|
2613 |
|
|
2614 |
=over 4 |
=over 4 |
2615 |
|
|
2616 |
=item id |
=item objectName |
|
|
|
|
ID to assign to the new entity. |
|
|
|
|
|
=item type |
|
|
|
|
|
Type name for the new entity. |
|
|
|
|
|
=item values |
|
2617 |
|
|
2618 |
Hash containing additional values that might be needed by the data generation methods (optional). |
Name of the entity or relationship to be indexed. |
2619 |
|
|
2620 |
=back |
=back |
2621 |
|
|
2622 |
=cut |
=cut |
2623 |
|
|
2624 |
sub GenerateEntity { |
sub CreateSearchIndex { |
2625 |
# Get the parameters. |
# Get the parameters. |
2626 |
my ($self, $id, $type, $values) = @_; |
my ($self, $objectName) = @_; |
2627 |
# Create the return hash. |
# Get the relation's entity/relationship structure. |
2628 |
my $this = { id => $id }; |
my $structure = $self->_GetStructure($objectName); |
2629 |
# Get the metadata structure. |
# Get the database handle. |
2630 |
my $metadata = $self->{_metaData}; |
my $dbh = $self->{_dbh}; |
2631 |
# Get this entity's list of fields. |
Trace("Checking for search fields in $objectName.") if T(3); |
2632 |
if (!exists $metadata->{Entities}->{$type}) { |
# Check for a searchable fields list. |
2633 |
Confess("Unrecognized entity type $type in GenerateEntity."); |
if (exists $structure->{searchFields}) { |
2634 |
} else { |
# Here we know that we need to create a full-text search index. |
2635 |
my $entity = $metadata->{Entities}->{$type}; |
# Get an SQL-formatted field name list. |
2636 |
my $fields = $entity->{Fields}; |
my $fields = join(", ", _FixNames(@{$structure->{searchFields}})); |
2637 |
# Generate data from the fields. |
# Create the index. If it already exists, it will be dropped. |
2638 |
_GenerateFields($this, $fields, $type, $values); |
$dbh->create_index(tbl => $objectName, idx => "search_idx", |
2639 |
|
flds => $fields, kind => 'fulltext'); |
2640 |
|
Trace("Index created for $fields in $objectName.") if T(2); |
2641 |
} |
} |
|
# Return the hash created. |
|
|
return $this; |
|
2642 |
} |
} |
2643 |
|
|
2644 |
=head3 GetEntity |
=head3 DropRelation |
2645 |
|
|
2646 |
C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >> |
C<< $erdb->DropRelation($relationName); >> |
2647 |
|
|
2648 |
Return an object describing the entity instance with a specified ID. |
Physically drop a relation from the database. |
2649 |
|
|
2650 |
=over 4 |
=over 4 |
2651 |
|
|
2652 |
=item entityType |
=item relationName |
2653 |
|
|
2654 |
Entity type name. |
Name of the relation to drop. If it does not exist, this method will have |
2655 |
|
no effect. |
2656 |
|
|
2657 |
=item ID |
=back |
2658 |
|
|
2659 |
ID of the desired entity. |
=cut |
2660 |
|
|
2661 |
|
sub DropRelation { |
2662 |
|
# Get the parameters. |
2663 |
|
my ($self, $relationName) = @_; |
2664 |
|
# Get the database handle. |
2665 |
|
my $dbh = $self->{_dbh}; |
2666 |
|
# Drop the relation. The method used here has no effect if the relation |
2667 |
|
# does not exist. |
2668 |
|
Trace("Invoking DB Kernel to drop $relationName.") if T(3); |
2669 |
|
$dbh->drop_table(tbl => $relationName); |
2670 |
|
} |
2671 |
|
|
2672 |
|
=head3 MatchSqlPattern |
2673 |
|
|
2674 |
|
C<< my $matched = ERDB::MatchSqlPattern($value, $pattern); >> |
2675 |
|
|
2676 |
|
Determine whether or not a specified value matches an SQL pattern. An SQL |
2677 |
|
pattern has two wild card characters: C<%> that matches multiple characters, |
2678 |
|
and C<_> that matches a single character. These can be escaped using a |
2679 |
|
backslash (C<\>). We pull this off by converting the SQL pattern to a |
2680 |
|
PERL regular expression. As per SQL rules, the match is case-insensitive. |
2681 |
|
|
2682 |
|
=over 4 |
2683 |
|
|
2684 |
|
=item value |
2685 |
|
|
2686 |
|
Value to be matched against the pattern. Note that an undefined or empty |
2687 |
|
value will not match anything. |
2688 |
|
|
2689 |
|
=item pattern |
2690 |
|
|
2691 |
|
SQL pattern against which to match the value. An undefined or empty pattern will |
2692 |
|
match everything. |
2693 |
|
|
2694 |
|
=item RETURN |
2695 |
|
|
2696 |
|
Returns TRUE if the value and pattern match, else FALSE. |
2697 |
|
|
2698 |
|
=back |
2699 |
|
|
2700 |
|
=cut |
2701 |
|
|
2702 |
|
sub MatchSqlPattern { |
2703 |
|
# Get the parameters. |
2704 |
|
my ($value, $pattern) = @_; |
2705 |
|
# Declare the return variable. |
2706 |
|
my $retVal; |
2707 |
|
# Insure we have a pattern. |
2708 |
|
if (! defined($pattern) || $pattern eq "") { |
2709 |
|
$retVal = 1; |
2710 |
|
} else { |
2711 |
|
# Break the pattern into pieces around the wildcard characters. Because we |
2712 |
|
# use parentheses in the split function's delimiter expression, we'll get |
2713 |
|
# list elements for the delimiters as well as the rest of the string. |
2714 |
|
my @pieces = split /([_%]|\\[_%])/, $pattern; |
2715 |
|
# Check some fast special cases. |
2716 |
|
if ($pattern eq '%') { |
2717 |
|
# A null pattern matches everything. |
2718 |
|
$retVal = 1; |
2719 |
|
} elsif (@pieces == 1) { |
2720 |
|
# No wildcards, so we have a literal comparison. Note we're case-insensitive. |
2721 |
|
$retVal = (lc($value) eq lc($pattern)); |
2722 |
|
} elsif (@pieces == 2 && $pieces[1] eq '%') { |
2723 |
|
# A wildcard at the end, so we have a substring match. This is also case-insensitive. |
2724 |
|
$retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0])); |
2725 |
|
} else { |
2726 |
|
# Okay, we have to do it the hard way. Convert each piece to a PERL pattern. |
2727 |
|
my $realPattern = ""; |
2728 |
|
for my $piece (@pieces) { |
2729 |
|
# Determine the type of piece. |
2730 |
|
if ($piece eq "") { |
2731 |
|
# Empty pieces are ignored. |
2732 |
|
} elsif ($piece eq "%") { |
2733 |
|
# Here we have a multi-character wildcard. Note that it can match |
2734 |
|
# zero or more characters. |
2735 |
|
$realPattern .= ".*" |
2736 |
|
} elsif ($piece eq "_") { |
2737 |
|
# Here we have a single-character wildcard. |
2738 |
|
$realPattern .= "."; |
2739 |
|
} elsif ($piece eq "\\%" || $piece eq "\\_") { |
2740 |
|
# This is an escape sequence (which is a rare thing, actually). |
2741 |
|
$realPattern .= substr($piece, 1, 1); |
2742 |
|
} else { |
2743 |
|
# Here we have raw text. |
2744 |
|
$realPattern .= quotemeta($piece); |
2745 |
|
} |
2746 |
|
} |
2747 |
|
# Do the match. |
2748 |
|
$retVal = ($value =~ /^$realPattern$/i ? 1 : 0); |
2749 |
|
} |
2750 |
|
} |
2751 |
|
# Return the result. |
2752 |
|
return $retVal; |
2753 |
|
} |
2754 |
|
|
2755 |
|
=head3 GetEntity |
2756 |
|
|
2757 |
|
C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >> |
2758 |
|
|
2759 |
|
Return an object describing the entity instance with a specified ID. |
2760 |
|
|
2761 |
|
=over 4 |
2762 |
|
|
2763 |
|
=item entityType |
2764 |
|
|
2765 |
|
Entity type name. |
2766 |
|
|
2767 |
|
=item ID |
2768 |
|
|
2769 |
|
ID of the desired entity. |
2770 |
|
|
2771 |
=item RETURN |
=item RETURN |
2772 |
|
|
2781 |
# Get the parameters. |
# Get the parameters. |
2782 |
my ($self, $entityType, $ID) = @_; |
my ($self, $entityType, $ID) = @_; |
2783 |
# Create a query. |
# Create a query. |
2784 |
my $query = $self->Get([$entityType], "$entityType(id) = ?", $ID); |
my $query = $self->Get([$entityType], "$entityType(id) = ?", [$ID]); |
2785 |
# Get the first (and only) object. |
# Get the first (and only) object. |
2786 |
my $retVal = $query->Fetch(); |
my $retVal = $query->Fetch(); |
2787 |
# Return the result. |
# Return the result. |
2788 |
return $retVal; |
return $retVal; |
2789 |
} |
} |
2790 |
|
|
2791 |
|
=head3 GetChoices |
2792 |
|
|
2793 |
|
C<< my @values = $erdb->GetChoices($entityName, $fieldName); >> |
2794 |
|
|
2795 |
|
Return a list of all the values for the specified field that are represented in the |
2796 |
|
specified entity. |
2797 |
|
|
2798 |
|
Note that if the field is not indexed, then this will be a very slow operation. |
2799 |
|
|
2800 |
|
=over 4 |
2801 |
|
|
2802 |
|
=item entityName |
2803 |
|
|
2804 |
|
Name of an entity in the database. |
2805 |
|
|
2806 |
|
=item fieldName |
2807 |
|
|
2808 |
|
Name of a field belonging to the entity. This is a raw field name without |
2809 |
|
the standard parenthesized notation used in most calls. |
2810 |
|
|
2811 |
|
=item RETURN |
2812 |
|
|
2813 |
|
Returns a list of the distinct values for the specified field in the database. |
2814 |
|
|
2815 |
|
=back |
2816 |
|
|
2817 |
|
=cut |
2818 |
|
|
2819 |
|
sub GetChoices { |
2820 |
|
# Get the parameters. |
2821 |
|
my ($self, $entityName, $fieldName) = @_; |
2822 |
|
# Declare the return variable. |
2823 |
|
my @retVal; |
2824 |
|
# Get the entity data structure. |
2825 |
|
my $entityData = $self->_GetStructure($entityName); |
2826 |
|
# Get the field. |
2827 |
|
my $fieldHash = $entityData->{Fields}; |
2828 |
|
if (! exists $fieldHash->{$fieldName}) { |
2829 |
|
Confess("$fieldName not found in $entityName."); |
2830 |
|
} else { |
2831 |
|
# Get the name of the relation containing the field. |
2832 |
|
my $relation = $fieldHash->{$fieldName}->{relation}; |
2833 |
|
# Fix up the field name. |
2834 |
|
my $realName = _FixName($fieldName); |
2835 |
|
# Get the database handle. |
2836 |
|
my $dbh = $self->{_dbh}; |
2837 |
|
# Query the database. |
2838 |
|
my $results = $dbh->SQL("SELECT DISTINCT $realName FROM $relation"); |
2839 |
|
# Clean the results. They are stored as a list of lists, and we just want the one list. |
2840 |
|
@retVal = sort map { $_->[0] } @{$results}; |
2841 |
|
} |
2842 |
|
# Return the result. |
2843 |
|
return @retVal; |
2844 |
|
} |
2845 |
|
|
2846 |
=head3 GetEntityValues |
=head3 GetEntityValues |
2847 |
|
|
2848 |
C<< my @values = $erdb->GetEntityValues($entityType, $ID, \@fields); >> |
C<< my @values = $erdb->GetEntityValues($entityType, $ID, \@fields); >> |
2849 |
|
|
2850 |
Return a list of values from a specified entity instance. |
Return a list of values from a specified entity instance. If the entity instance |
2851 |
|
does not exist, an empty list is returned. |
2852 |
|
|
2853 |
=over 4 |
=over 4 |
2854 |
|
|
2905 |
spreadsheet cell, and each feature will be represented by a list containing the |
spreadsheet cell, and each feature will be represented by a list containing the |
2906 |
feature ID followed by all of its aliases. |
feature ID followed by all of its aliases. |
2907 |
|
|
2908 |
C<< $query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(alias)']); >> |
C<< @query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(alias)']); >> |
2909 |
|
|
2910 |
=over 4 |
=over 4 |
2911 |
|
|
2950 |
# list is a scalar we convert it into a singleton list. |
# list is a scalar we convert it into a singleton list. |
2951 |
my @parmList = (); |
my @parmList = (); |
2952 |
if (ref $parameterList eq "ARRAY") { |
if (ref $parameterList eq "ARRAY") { |
2953 |
|
Trace("GetAll parm list is an array.") if T(4); |
2954 |
@parmList = @{$parameterList}; |
@parmList = @{$parameterList}; |
2955 |
} else { |
} else { |
2956 |
|
Trace("GetAll parm list is a scalar: $parameterList.") if T(4); |
2957 |
push @parmList, $parameterList; |
push @parmList, $parameterList; |
2958 |
} |
} |
2959 |
# Insure the counter has a value. |
# Insure the counter has a value. |
2965 |
$filterClause .= " LIMIT $count"; |
$filterClause .= " LIMIT $count"; |
2966 |
} |
} |
2967 |
# Create the query. |
# Create the query. |
2968 |
my $query = $self->Get($objectNames, $filterClause, @parmList); |
my $query = $self->Get($objectNames, $filterClause, \@parmList); |
2969 |
# Set up a counter of the number of records read. |
# Set up a counter of the number of records read. |
2970 |
my $fetched = 0; |
my $fetched = 0; |
2971 |
# Loop through the records returned, extracting the fields. Note that if the |
# Loop through the records returned, extracting the fields. Note that if the |
2976 |
push @retVal, \@rowData; |
push @retVal, \@rowData; |
2977 |
$fetched++; |
$fetched++; |
2978 |
} |
} |
2979 |
|
Trace("$fetched rows returned in GetAll.") if T(SQL => 4); |
2980 |
# Return the resulting list. |
# Return the resulting list. |
2981 |
return @retVal; |
return @retVal; |
2982 |
} |
} |
2983 |
|
|
2984 |
|
=head3 Exists |
2985 |
|
|
2986 |
|
C<< my $found = $sprout->Exists($entityName, $entityID); >> |
2987 |
|
|
2988 |
|
Return TRUE if an entity exists, else FALSE. |
2989 |
|
|
2990 |
|
=over 4 |
2991 |
|
|
2992 |
|
=item entityName |
2993 |
|
|
2994 |
|
Name of the entity type (e.g. C<Feature>) relevant to the existence check. |
2995 |
|
|
2996 |
|
=item entityID |
2997 |
|
|
2998 |
|
ID of the entity instance whose existence is to be checked. |
2999 |
|
|
3000 |
|
=item RETURN |
3001 |
|
|
3002 |
|
Returns TRUE if the entity instance exists, else FALSE. |
3003 |
|
|
3004 |
|
=back |
3005 |
|
|
3006 |
|
=cut |
3007 |
|
#: Return Type $; |
3008 |
|
sub Exists { |
3009 |
|
# Get the parameters. |
3010 |
|
my ($self, $entityName, $entityID) = @_; |
3011 |
|
# Check for the entity instance. |
3012 |
|
Trace("Checking existence of $entityName with ID=$entityID.") if T(4); |
3013 |
|
my $testInstance = $self->GetEntity($entityName, $entityID); |
3014 |
|
# Return an existence indicator. |
3015 |
|
my $retVal = ($testInstance ? 1 : 0); |
3016 |
|
return $retVal; |
3017 |
|
} |
3018 |
|
|
3019 |
=head3 EstimateRowSize |
=head3 EstimateRowSize |
3020 |
|
|
3021 |
C<< my $rowSize = $erdb->EstimateRowSize($relName); >> |
C<< my $rowSize = $erdb->EstimateRowSize($relName); >> |
3054 |
return $retVal; |
return $retVal; |
3055 |
} |
} |
3056 |
|
|
3057 |
=head2 Internal Utility Methods |
=head3 GetFieldTable |
3058 |
|
|
3059 |
=head3 GetLoadStats |
C<< my $fieldHash = $self->GetFieldTable($objectnName); >> |
3060 |
|
|
3061 |
Return a blank statistics object for use by the load methods. |
Get the field structure for a specified entity or relationship. |
3062 |
|
|
3063 |
This is a static method. |
=over 4 |
3064 |
|
|
3065 |
|
=item objectName |
3066 |
|
|
3067 |
|
Name of the desired entity or relationship. |
3068 |
|
|
3069 |
|
=item RETURN |
3070 |
|
|
3071 |
|
The table containing the field descriptors for the specified object. |
3072 |
|
|
3073 |
|
=back |
3074 |
|
|
3075 |
=cut |
=cut |
3076 |
|
|
3077 |
sub _GetLoadStats{ |
sub GetFieldTable { |
3078 |
return Stats->new(); |
# Get the parameters. |
3079 |
|
my ($self, $objectName) = @_; |
3080 |
|
# Get the descriptor from the metadata. |
3081 |
|
my $objectData = $self->_GetStructure($objectName); |
3082 |
|
# Return the object's field table. |
3083 |
|
return $objectData->{Fields}; |
3084 |
} |
} |
3085 |
|
|
3086 |
=head3 GenerateFields |
=head3 SplitKeywords |
3087 |
|
|
3088 |
Generate field values from a field structure and store in a specified table. The field names |
C<< my @keywords = ERDB::SplitKeywords($keywordString); >> |
|
are first sorted by pass count, certain pre-defined fields are removed from the list, and |
|
|
then we rip through them evaluation the data generation string. Fields in the primary relation |
|
|
are stored as scalars; fields in secondary relations are stored as value lists. |
|
3089 |
|
|
3090 |
This is a static method. |
This method returns a list of the positive keywords in the specified |
3091 |
|
keyword string. All of the operators will have been stripped off, |
3092 |
|
and if the keyword is preceded by a minus operator (C<->), it will |
3093 |
|
not be in the list returned. The idea here is to get a list of the |
3094 |
|
keywords the user wants to see. The list will be processed to remove |
3095 |
|
duplicates. |
3096 |
|
|
3097 |
|
It is possible to create a string that confuses this method. For example |
3098 |
|
|
3099 |
|
frog toad -frog |
3100 |
|
|
3101 |
|
would return both C<frog> and C<toad>. If this is a problem we can deal |
3102 |
|
with it later. |
3103 |
|
|
3104 |
=over 4 |
=over 4 |
3105 |
|
|
3106 |
=item this |
=item keywordString |
3107 |
|
|
3108 |
Hash table into which the field values should be placed. |
The keyword string to be parsed. |
3109 |
|
|
3110 |
=item fields |
=item RETURN |
3111 |
|
|
3112 |
Field structure from which the field descriptors should be taken. |
Returns a list of the words in the keyword string the user wants to |
3113 |
|
see. |
3114 |
|
|
3115 |
=item type |
=back |
3116 |
|
|
3117 |
|
=cut |
3118 |
|
|
3119 |
|
sub SplitKeywords { |
3120 |
|
# Get the parameters. |
3121 |
|
my ($keywordString) = @_; |
3122 |
|
# Make a safety copy of the string. (This helps during debugging.) |
3123 |
|
my $workString = $keywordString; |
3124 |
|
# Convert operators we don't care about to spaces. |
3125 |
|
$workString =~ tr/+"()<>/ /; |
3126 |
|
# Split the rest of the string along space boundaries. Note that we |
3127 |
|
# eliminate any words that are zero length or begin with a minus sign. |
3128 |
|
my @wordList = grep { $_ && substr($_, 0, 1) ne "-" } split /\s+/, $workString; |
3129 |
|
# Use a hash to remove duplicates. |
3130 |
|
my %words = map { $_ => 1 } @wordList; |
3131 |
|
# Return the result. |
3132 |
|
return sort keys %words; |
3133 |
|
} |
3134 |
|
|
3135 |
|
=head3 ValidateFieldName |
3136 |
|
|
3137 |
Type name of the object whose fields are being generated. |
C<< my $okFlag = ERDB::ValidateFieldName($fieldName); >> |
3138 |
|
|
3139 |
=item values (optional) |
Return TRUE if the specified field name is valid, else FALSE. Valid field names must |
3140 |
|
be hyphenated words subject to certain restrictions. |
3141 |
|
|
3142 |
Reference to a value structure from which additional values can be taken. |
=over 4 |
3143 |
|
|
3144 |
=item from (optiona) |
=item fieldName |
3145 |
|
|
3146 |
Reference to the source entity instance if relationship data is being generated. |
Field name to be validated. |
3147 |
|
|
3148 |
=item to (optional) |
=item RETURN |
3149 |
|
|
3150 |
Reference to the target entity instance if relationship data is being generated. |
Returns TRUE if the field name is valid, else FALSE. |
3151 |
|
|
3152 |
=back |
=back |
3153 |
|
|
3154 |
=cut |
=cut |
3155 |
|
|
3156 |
sub _GenerateFields { |
sub ValidateFieldName { |
3157 |
# Get the parameters. |
# Get the parameters. |
3158 |
my ($this, $fields, $type, $values, $from, $to) = @_; |
my ($fieldName) = @_; |
3159 |
# Sort the field names by pass number. |
# Declare the return variable. The field name is valid until we hear |
3160 |
my @fieldNames = sort { $fields->{$a}->{DataGen}->{pass} <=> $fields->{$b}->{DataGen}->{pass} } keys %{$fields}; |
# differently. |
3161 |
# Loop through the field names, generating data. |
my $retVal = 1; |
3162 |
for my $name (@fieldNames) { |
# Compute the maximum name length. |
3163 |
# Only proceed if this field needs to be generated. |
my $maxLen = $TypeTable{'name-string'}->{maxLen}; |
3164 |
if (!exists $this->{$name}) { |
# Look for bad stuff in the name. |
3165 |
# Get this field's data generation descriptor. |
if ($fieldName =~ /--/) { |
3166 |
my $fieldDescriptor = $fields->{$name}; |
# Here we have a doubled minus sign. |
3167 |
my $data = $fieldDescriptor->{DataGen}; |
Trace("Field name $fieldName has a doubled hyphen.") if T(1); |
3168 |
# Get the code to generate the field value. |
$retVal = 0; |
3169 |
my $codeString = $data->{content}; |
} elsif ($fieldName !~ /^[A-Za-z]/) { |
3170 |
# Determine whether or not this field is in the primary relation. |
# Here the field name is missing the initial letter. |
3171 |
if ($fieldDescriptor->{relation} eq $type) { |
Trace("Field name $fieldName does not begin with a letter.") if T(1); |
3172 |
# Here we have a primary relation field. Store the field value as |
$retVal = 0; |
3173 |
# a scalar. |
} elsif (length($fieldName) > $maxLen) { |
3174 |
$this->{$name} = eval($codeString); |
# Here the field name is too long. |
3175 |
|
Trace("Maximum field name length is $maxLen. Field name must be truncated to " . substr($fieldName,0, $maxLen) . "."); |
3176 |
} else { |
} else { |
3177 |
# Here we have a secondary relation field. Create a null list |
# Strip out the minus signs. Everything remaining must be a letter, |
3178 |
# and push the desired number of field values onto it. |
# underscore, or digit. |
3179 |
my @fieldValues = (); |
my $strippedName = $fieldName; |
3180 |
my $count = IntGen(0,$data->{testCount}); |
$strippedName =~ s/-//g; |
3181 |
for (my $i = 0; $i < $count; $i++) { |
if ($strippedName !~ /^(\w|\d)+$/) { |
3182 |
my $newValue = eval($codeString); |
Trace("Field name $fieldName contains illegal characters.") if T(1); |
3183 |
push @fieldValues, $newValue; |
$retVal = 0; |
3184 |
|
} |
3185 |
|
} |
3186 |
|
# Return the result. |
3187 |
|
return $retVal; |
3188 |
|
} |
3189 |
|
|
3190 |
|
=head3 ReadMetaXML |
3191 |
|
|
3192 |
|
C<< my $rawMetaData = ERDB::ReadDBD($fileName); >> |
3193 |
|
|
3194 |
|
This method reads a raw database definition XML file and returns it. |
3195 |
|
Normally, the metadata used by the ERDB system has been processed and |
3196 |
|
modified to make it easier to load and retrieve the data; however, |
3197 |
|
this method can be used to get the data in its raw form. |
3198 |
|
|
3199 |
|
=over 4 |
3200 |
|
|
3201 |
|
=item fileName |
3202 |
|
|
3203 |
|
Name of the XML file to read. |
3204 |
|
|
3205 |
|
=item RETURN |
3206 |
|
|
3207 |
|
Returns a hash reference containing the raw XML data from the specified file. |
3208 |
|
|
3209 |
|
=back |
3210 |
|
|
3211 |
|
=cut |
3212 |
|
|
3213 |
|
sub ReadMetaXML { |
3214 |
|
# Get the parameters. |
3215 |
|
my ($fileName) = @_; |
3216 |
|
# Read the XML. |
3217 |
|
my $retVal = XML::Simple::XMLin($fileName, %XmlOptions, %XmlInOpts); |
3218 |
|
Trace("XML metadata loaded from file $fileName.") if T(1); |
3219 |
|
# Return the result. |
3220 |
|
return $retVal; |
3221 |
|
} |
3222 |
|
|
3223 |
|
=head3 GetEntityFieldHash |
3224 |
|
|
3225 |
|
C<< my $fieldHashRef = ERDB::GetEntityFieldHash($structure, $entityName); >> |
3226 |
|
|
3227 |
|
Get the field hash of the named entity in the specified raw XML structure. |
3228 |
|
The field hash may not exist, in which case we need to create it. |
3229 |
|
|
3230 |
|
=over 4 |
3231 |
|
|
3232 |
|
=item structure |
3233 |
|
|
3234 |
|
Raw XML structure defininng the database. This is not the run-time XML used by |
3235 |
|
an ERDB object, since that has all sorts of optimizations built-in. |
3236 |
|
|
3237 |
|
=item entityName |
3238 |
|
|
3239 |
|
Name of the entity whose field structure is desired. |
3240 |
|
|
3241 |
|
=item RETURN |
3242 |
|
|
3243 |
|
Returns the field hash used to define the entity's fields. |
3244 |
|
|
3245 |
|
=back |
3246 |
|
|
3247 |
|
=cut |
3248 |
|
|
3249 |
|
sub GetEntityFieldHash { |
3250 |
|
# Get the parameters. |
3251 |
|
my ($structure, $entityName) = @_; |
3252 |
|
# Get the entity structure. |
3253 |
|
my $entityData = $structure->{Entities}->{$entityName}; |
3254 |
|
# Look for a field structure. |
3255 |
|
my $retVal = $entityData->{Fields}; |
3256 |
|
# If it doesn't exist, create it. |
3257 |
|
if (! defined($retVal)) { |
3258 |
|
$entityData->{Fields} = {}; |
3259 |
|
$retVal = $entityData->{Fields}; |
3260 |
} |
} |
3261 |
# Store the value list in the main hash. |
# Return the result. |
3262 |
$this->{$name} = \@fieldValues; |
return $retVal; |
3263 |
} |
} |
3264 |
|
|
3265 |
|
=head3 WriteMetaXML |
3266 |
|
|
3267 |
|
C<< ERDB::WriteMetaXML($structure, $fileName); >> |
3268 |
|
|
3269 |
|
Write the metadata XML to a file. This method is the reverse of L</ReadMetaXML>, and is |
3270 |
|
used to update the database definition. It must be used with care, however, since it |
3271 |
|
will only work on a raw structure, not on the processed structure created by an ERDB |
3272 |
|
constructor. |
3273 |
|
|
3274 |
|
=over 4 |
3275 |
|
|
3276 |
|
=item structure |
3277 |
|
|
3278 |
|
XML structure to be written to the file. |
3279 |
|
|
3280 |
|
=item fileName |
3281 |
|
|
3282 |
|
Name of the output file to which the updated XML should be stored. |
3283 |
|
|
3284 |
|
=back |
3285 |
|
|
3286 |
|
=cut |
3287 |
|
|
3288 |
|
sub WriteMetaXML { |
3289 |
|
# Get the parameters. |
3290 |
|
my ($structure, $fileName) = @_; |
3291 |
|
# Compute the output. |
3292 |
|
my $fileString = XML::Simple::XMLout($structure, %XmlOptions, %XmlOutOpts); |
3293 |
|
# Write it to the file. |
3294 |
|
my $xmlOut = Open(undef, ">$fileName"); |
3295 |
|
print $xmlOut $fileString; |
3296 |
} |
} |
3297 |
|
|
3298 |
|
|
3299 |
|
=head3 HTMLNote |
3300 |
|
|
3301 |
|
Convert a note or comment to HTML by replacing some bulletin-board codes with HTML. The codes |
3302 |
|
supported are C<[b]> for B<bold>, C<[i]> for I<italics>, and C<[p]> for a new paragraph. |
3303 |
|
Except for C<[p]>, all the codes are closed by slash-codes. So, for |
3304 |
|
example, C<[b]Feature[/b]> displays the string C<Feature> in boldface. |
3305 |
|
|
3306 |
|
C<< my $realHtml = ERDB::HTMLNote($dataString); >> |
3307 |
|
|
3308 |
|
=over 4 |
3309 |
|
|
3310 |
|
=item dataString |
3311 |
|
|
3312 |
|
String to convert to HTML. |
3313 |
|
|
3314 |
|
=item RETURN |
3315 |
|
|
3316 |
|
An HTML string derived from the input string. |
3317 |
|
|
3318 |
|
=back |
3319 |
|
|
3320 |
|
=cut |
3321 |
|
|
3322 |
|
sub HTMLNote { |
3323 |
|
# Get the parameter. |
3324 |
|
my ($dataString) = @_; |
3325 |
|
# HTML-escape the text. |
3326 |
|
my $retVal = CGI::escapeHTML($dataString); |
3327 |
|
# Substitute the bulletin board codes. |
3328 |
|
$retVal =~ s!\[(/?[bi])\]!<$1>!g; |
3329 |
|
$retVal =~ s!\[p\]!</p><p>!g; |
3330 |
|
$retVal =~ s!\[link\s+([^\]]+)\]!<a href="$1">!g; |
3331 |
|
$retVal =~ s!\[/link\]!</a>!g; |
3332 |
|
# Return the result. |
3333 |
|
return $retVal; |
3334 |
} |
} |
3335 |
|
|
3336 |
|
|
3337 |
|
=head2 Data Mining Methods |
3338 |
|
|
3339 |
|
=head3 GetUsefulCrossValues |
3340 |
|
|
3341 |
|
C<< my @attrNames = $sprout->GetUsefulCrossValues($sourceEntity, $relationship); >> |
3342 |
|
|
3343 |
|
Return a list of the useful attributes that would be returned by a B<Cross> call |
3344 |
|
from an entity of the source entity type through the specified relationship. This |
3345 |
|
means it will return the fields of the target entity type and the intersection data |
3346 |
|
fields in the relationship. Only primary table fields are returned. In other words, |
3347 |
|
the field names returned will be for fields where there is always one and only one |
3348 |
|
value. |
3349 |
|
|
3350 |
|
=over 4 |
3351 |
|
|
3352 |
|
=item sourceEntity |
3353 |
|
|
3354 |
|
Name of the entity from which the relationship crossing will start. |
3355 |
|
|
3356 |
|
=item relationship |
3357 |
|
|
3358 |
|
Name of the relationship being crossed. |
3359 |
|
|
3360 |
|
=item RETURN |
3361 |
|
|
3362 |
|
Returns a list of field names in Sprout field format (I<objectName>C<(>I<fieldName>C<)>. |
3363 |
|
|
3364 |
|
=back |
3365 |
|
|
3366 |
|
=cut |
3367 |
|
#: Return Type @; |
3368 |
|
sub GetUsefulCrossValues { |
3369 |
|
# Get the parameters. |
3370 |
|
my ($self, $sourceEntity, $relationship) = @_; |
3371 |
|
# Declare the return variable. |
3372 |
|
my @retVal = (); |
3373 |
|
# Determine the target entity for the relationship. This is whichever entity is not |
3374 |
|
# the source entity. So, if the source entity is the FROM, we'll get the name of |
3375 |
|
# the TO, and vice versa. |
3376 |
|
my $relStructure = $self->_GetStructure($relationship); |
3377 |
|
my $targetEntityType = ($relStructure->{from} eq $sourceEntity ? "to" : "from"); |
3378 |
|
my $targetEntity = $relStructure->{$targetEntityType}; |
3379 |
|
# Get the field table for the entity. |
3380 |
|
my $entityFields = $self->GetFieldTable($targetEntity); |
3381 |
|
# The field table is a hash. The hash key is the field name. The hash value is a structure. |
3382 |
|
# For the entity fields, the key aspect of the target structure is that the {relation} value |
3383 |
|
# must match the entity name. |
3384 |
|
my @fieldList = map { "$targetEntity($_)" } grep { $entityFields->{$_}->{relation} eq $targetEntity } |
3385 |
|
keys %{$entityFields}; |
3386 |
|
# Push the fields found onto the return variable. |
3387 |
|
push @retVal, sort @fieldList; |
3388 |
|
# Get the field table for the relationship. |
3389 |
|
my $relationshipFields = $self->GetFieldTable($relationship); |
3390 |
|
# Here we have a different rule. We want all the fields other than "from-link" and "to-link". |
3391 |
|
# This may end up being an empty set. |
3392 |
|
my @fieldList2 = map { "$relationship($_)" } grep { $_ ne "from-link" && $_ ne "to-link" } |
3393 |
|
keys %{$relationshipFields}; |
3394 |
|
# Push these onto the return list. |
3395 |
|
push @retVal, sort @fieldList2; |
3396 |
|
# Return the result. |
3397 |
|
return @retVal; |
3398 |
|
} |
3399 |
|
|
3400 |
|
=head3 FindColumn |
3401 |
|
|
3402 |
|
C<< my $colIndex = ERDB::FindColumn($headerLine, $columnIdentifier); >> |
3403 |
|
|
3404 |
|
Return the location a desired column in a data mining header line. The data |
3405 |
|
mining header line is a tab-separated list of column names. The column |
3406 |
|
identifier is either the numerical index of a column or the actual column |
3407 |
|
name. |
3408 |
|
|
3409 |
|
=over 4 |
3410 |
|
|
3411 |
|
=item headerLine |
3412 |
|
|
3413 |
|
The header line from a data mining command, which consists of a tab-separated |
3414 |
|
list of column names. |
3415 |
|
|
3416 |
|
=item columnIdentifier |
3417 |
|
|
3418 |
|
Either the ordinal number of the desired column (1-based), or the name of the |
3419 |
|
desired column. |
3420 |
|
|
3421 |
|
=item RETURN |
3422 |
|
|
3423 |
|
Returns the array index (0-based) of the desired column. |
3424 |
|
|
3425 |
|
=back |
3426 |
|
|
3427 |
|
=cut |
3428 |
|
|
3429 |
|
sub FindColumn { |
3430 |
|
# Get the parameters. |
3431 |
|
my ($headerLine, $columnIdentifier) = @_; |
3432 |
|
# Declare the return variable. |
3433 |
|
my $retVal; |
3434 |
|
# Split the header line into column names. |
3435 |
|
my @headers = ParseColumns($headerLine); |
3436 |
|
# Determine whether we have a number or a name. |
3437 |
|
if ($columnIdentifier =~ /^\d+$/) { |
3438 |
|
# Here we have a number. Subtract 1 and validate the result. |
3439 |
|
$retVal = $columnIdentifier - 1; |
3440 |
|
if ($retVal < 0 || $retVal > $#headers) { |
3441 |
|
Confess("Invalid column identifer \"$columnIdentifier\": value out of range."); |
3442 |
|
} |
3443 |
|
} else { |
3444 |
|
# Here we have a name. We need to find it in the list. |
3445 |
|
for (my $i = 0; $i <= $#headers && ! defined($retVal); $i++) { |
3446 |
|
if ($headers[$i] eq $columnIdentifier) { |
3447 |
|
$retVal = $i; |
3448 |
|
} |
3449 |
|
} |
3450 |
|
if (! defined($retVal)) { |
3451 |
|
Confess("Invalid column identifier \"$columnIdentifier\": value not found."); |
3452 |
|
} |
3453 |
|
} |
3454 |
|
# Return the result. |
3455 |
|
return $retVal; |
3456 |
|
} |
3457 |
|
|
3458 |
|
=head3 ParseColumns |
3459 |
|
|
3460 |
|
C<< my @columns = ERDB::ParseColumns($line); >> |
3461 |
|
|
3462 |
|
Convert the specified data line to a list of columns. |
3463 |
|
|
3464 |
|
=over 4 |
3465 |
|
|
3466 |
|
=item line |
3467 |
|
|
3468 |
|
A data mining input, consisting of a tab-separated list of columns terminated by a |
3469 |
|
new-line. |
3470 |
|
|
3471 |
|
=item RETURN |
3472 |
|
|
3473 |
|
Returns a list consisting of the column values. |
3474 |
|
|
3475 |
|
=back |
3476 |
|
|
3477 |
|
=cut |
3478 |
|
|
3479 |
|
sub ParseColumns { |
3480 |
|
# Get the parameters. |
3481 |
|
my ($line) = @_; |
3482 |
|
# Chop off the line-end. |
3483 |
|
chomp $line; |
3484 |
|
# Split it into a list. |
3485 |
|
my @retVal = split(/\t/, $line); |
3486 |
|
# Return the result. |
3487 |
|
return @retVal; |
3488 |
|
} |
3489 |
|
|
3490 |
|
=head2 Virtual Methods |
3491 |
|
|
3492 |
|
=head3 CleanKeywords |
3493 |
|
|
3494 |
|
C<< my $cleanedString = $erdb->CleanKeywords($searchExpression); >> |
3495 |
|
|
3496 |
|
Clean up a search expression or keyword list. This is a virtual method that may |
3497 |
|
be overridden by the subclass. The base-class method removes extra spaces |
3498 |
|
and converts everything to lower case. |
3499 |
|
|
3500 |
|
=over 4 |
3501 |
|
|
3502 |
|
=item searchExpression |
3503 |
|
|
3504 |
|
Search expression or keyword list to clean. Note that a search expression may |
3505 |
|
contain boolean operators which need to be preserved. This includes leading |
3506 |
|
minus signs. |
3507 |
|
|
3508 |
|
=item RETURN |
3509 |
|
|
3510 |
|
Cleaned expression or keyword list. |
3511 |
|
|
3512 |
|
=back |
3513 |
|
|
3514 |
|
=cut |
3515 |
|
|
3516 |
|
sub CleanKeywords { |
3517 |
|
# Get the parameters. |
3518 |
|
my ($self, $searchExpression) = @_; |
3519 |
|
# Lower-case the expression and copy it into the return variable. Note that we insure we |
3520 |
|
# don't accidentally end up with an undefined value. |
3521 |
|
my $retVal = lc($searchExpression || ""); |
3522 |
|
# Remove extra spaces. |
3523 |
|
$retVal =~ s/\s+/ /g; |
3524 |
|
$retVal =~ s/(^\s+)|(\s+$)//g; |
3525 |
|
# Return the result. |
3526 |
|
return $retVal; |
3527 |
|
} |
3528 |
|
|
3529 |
|
=head3 GetSourceObject |
3530 |
|
|
3531 |
|
C<< my $source = $erdb->GetSourceObject($entityName); >> |
3532 |
|
|
3533 |
|
Return the object to be used in loading special attributes of the specified entity. The |
3534 |
|
algorithm for loading special attributes is stored in the C<DataGen> elements of the |
3535 |
|
XML |
3536 |
|
|
3537 |
|
=head2 Internal Utility Methods |
3538 |
|
|
3539 |
|
=head3 _RelationMap |
3540 |
|
|
3541 |
|
C<< my @relationMap = _RelationMap($mappedNameHashRef, $mappedNameListRef); >> |
3542 |
|
|
3543 |
|
Create the relation map for an SQL query. The relation map is used by B<DBObject> |
3544 |
|
to determine how to interpret the results of the query. |
3545 |
|
|
3546 |
|
=over 4 |
3547 |
|
|
3548 |
|
=item mappedNameHashRef |
3549 |
|
|
3550 |
|
Reference to a hash that maps modified object names to real object names. |
3551 |
|
|
3552 |
|
=item mappedNameListRef |
3553 |
|
|
3554 |
|
Reference to a list of modified object names in the order they appear in the |
3555 |
|
SELECT list. |
3556 |
|
|
3557 |
|
=item RETURN |
3558 |
|
|
3559 |
|
Returns a list of 2-tuples. Each tuple consists of an object name as used in the |
3560 |
|
query followed by the actual name of that object. This enables the B<DBObject> to |
3561 |
|
determine the order of the tables in the query and which object name belongs to each |
3562 |
|
mapped object name. Most of the time these two values are the same; however, if a |
3563 |
|
relation occurs twice in the query, the relation name in the field list and WHERE |
3564 |
|
clause will use a mapped name (generally the actual relation name with a numeric |
3565 |
|
suffix) that does not match the actual relation name. |
3566 |
|
|
3567 |
|
=back |
3568 |
|
|
3569 |
|
=cut |
3570 |
|
|
3571 |
|
sub _RelationMap { |
3572 |
|
# Get the parameters. |
3573 |
|
my ($mappedNameHashRef, $mappedNameListRef) = @_; |
3574 |
|
# Declare the return variable. |
3575 |
|
my @retVal = (); |
3576 |
|
# Build the map. |
3577 |
|
for my $mappedName (@{$mappedNameListRef}) { |
3578 |
|
push @retVal, [$mappedName, $mappedNameHashRef->{$mappedName}]; |
3579 |
|
} |
3580 |
|
# Return it. |
3581 |
|
return @retVal; |
3582 |
|
} |
3583 |
|
|
3584 |
|
|
3585 |
|
=head3 _SetupSQL |
3586 |
|
|
3587 |
|
Process a list of object names and a filter clause so that they can be used to |
3588 |
|
build an SQL statement. This method takes in a reference to a list of object names |
3589 |
|
and a filter clause. It will return a corrected filter clause, a list of mapped |
3590 |
|
names and the mapped name hash. |
3591 |
|
|
3592 |
|
This is an instance method. |
3593 |
|
|
3594 |
|
=over 4 |
3595 |
|
|
3596 |
|
=item objectNames |
3597 |
|
|
3598 |
|
Reference to a list of the object names to be included in the query. |
3599 |
|
|
3600 |
|
=item filterClause |
3601 |
|
|
3602 |
|
A string containing the WHERE clause for the query (without the C<WHERE>) and also |
3603 |
|
optionally the C<ORDER BY> and C<LIMIT> clauses. |
3604 |
|
|
3605 |
|
=item matchClause |
3606 |
|
|
3607 |
|
An optional full-text search clause. If specified, it will be inserted at the |
3608 |
|
front of the WHERE clause. It should already be SQL-formatted; that is, the |
3609 |
|
field names should be in the form I<table>C<.>I<fieldName>. |
3610 |
|
|
3611 |
|
=item RETURN |
3612 |
|
|
3613 |
|
Returns a three-element list. The first element is the SQL statement suffix, beginning |
3614 |
|
with the FROM clause. The second element is a reference to a list of the names to be |
3615 |
|
used in retrieving the fields. The third element is a hash mapping the names to the |
3616 |
|
objects they represent. |
3617 |
|
|
3618 |
|
=back |
3619 |
|
|
3620 |
|
=cut |
3621 |
|
|
3622 |
|
sub _SetupSQL { |
3623 |
|
my ($self, $objectNames, $filterClause, $matchClause) = @_; |
3624 |
|
# Adjust the list of object names to account for multiple occurrences of the |
3625 |
|
# same object. We start with a hash table keyed on object name that will |
3626 |
|
# return the object suffix. The first time an object is encountered it will |
3627 |
|
# not be found in the hash. The next time the hash will map the object name |
3628 |
|
# to 2, then 3, and so forth. |
3629 |
|
my %objectHash = (); |
3630 |
|
# This list will contain the object names as they are to appear in the |
3631 |
|
# FROM list. |
3632 |
|
my @fromList = (); |
3633 |
|
# This list contains the suffixed object name for each object. It is exactly |
3634 |
|
# parallel to the list in the $objectNames parameter. |
3635 |
|
my @mappedNameList = (); |
3636 |
|
# Finally, this hash translates from a mapped name to its original object name. |
3637 |
|
my %mappedNameHash = (); |
3638 |
|
# Now we create the lists. Note that for every single name we push something into |
3639 |
|
# @fromList and @mappedNameList. This insures that those two arrays are exactly |
3640 |
|
# parallel to $objectNames. |
3641 |
|
for my $objectName (@{$objectNames}) { |
3642 |
|
# Get the next suffix for this object. |
3643 |
|
my $suffix = $objectHash{$objectName}; |
3644 |
|
if (! $suffix) { |
3645 |
|
# Here we are seeing the object for the first time. The object name |
3646 |
|
# is used as is. |
3647 |
|
push @mappedNameList, $objectName; |
3648 |
|
push @fromList, $objectName; |
3649 |
|
$mappedNameHash{$objectName} = $objectName; |
3650 |
|
# Denote the next suffix will be 2. |
3651 |
|
$objectHash{$objectName} = 2; |
3652 |
|
} else { |
3653 |
|
# Here we've seen the object before. We construct a new name using |
3654 |
|
# the suffix from the hash and update the hash. |
3655 |
|
my $mappedName = "$objectName$suffix"; |
3656 |
|
$objectHash{$objectName} = $suffix + 1; |
3657 |
|
# The FROM list has the object name followed by the mapped name. This |
3658 |
|
# tells SQL it's still the same table, but we're using a different name |
3659 |
|
# for it to avoid confusion. |
3660 |
|
push @fromList, "$objectName $mappedName"; |
3661 |
|
# The mapped-name list contains the real mapped name. |
3662 |
|
push @mappedNameList, $mappedName; |
3663 |
|
# Finally, enable us to get back from the mapped name to the object name. |
3664 |
|
$mappedNameHash{$mappedName} = $objectName; |
3665 |
|
} |
3666 |
|
} |
3667 |
|
# Begin the SELECT suffix. It starts with |
3668 |
|
# |
3669 |
|
# FROM name1, name2, ... nameN |
3670 |
|
# |
3671 |
|
my $suffix = "FROM " . join(', ', @fromList); |
3672 |
|
# Now for the WHERE. First, we need a place for the filter string. |
3673 |
|
my $filterString = ""; |
3674 |
|
# We will also keep a list of conditions to add to the WHERE clause in order to link |
3675 |
|
# entities and relationships as well as primary relations to secondary ones. |
3676 |
|
my @joinWhere = (); |
3677 |
|
# Check for a filter clause. |
3678 |
|
if ($filterClause) { |
3679 |
|
# Here we have one, so we convert its field names and add it to the query. First, |
3680 |
|
# We create a copy of the filter string we can work with. |
3681 |
|
$filterString = $filterClause; |
3682 |
|
# Next, we sort the object names by length. This helps protect us from finding |
3683 |
|
# object names inside other object names when we're doing our search and replace. |
3684 |
|
my @sortedNames = sort { length($b) - length($a) } @mappedNameList; |
3685 |
|
# The final preparatory step is to create a hash table of relation names. The |
3686 |
|
# table begins with the relation names already in the SELECT command. We may |
3687 |
|
# need to add relations later if there is filtering on a field in a secondary |
3688 |
|
# relation. The secondary relations are the ones that contain multiply- |
3689 |
|
# occurring or optional fields. |
3690 |
|
my %fromNames = map { $_ => 1 } @sortedNames; |
3691 |
|
# We are ready to begin. We loop through the object names, replacing each |
3692 |
|
# object name's field references by the corresponding SQL field reference. |
3693 |
|
# Along the way, if we find a secondary relation, we will need to add it |
3694 |
|
# to the FROM clause. |
3695 |
|
for my $mappedName (@sortedNames) { |
3696 |
|
# Get the length of the object name plus 2. This is the value we add to the |
3697 |
|
# size of the field name to determine the size of the field reference as a |
3698 |
|
# whole. |
3699 |
|
my $nameLength = 2 + length $mappedName; |
3700 |
|
# Get the real object name for this mapped name. |
3701 |
|
my $objectName = $mappedNameHash{$mappedName}; |
3702 |
|
Trace("Processing $mappedName for object $objectName.") if T(4); |
3703 |
|
# Get the object's field list. |
3704 |
|
my $fieldList = $self->GetFieldTable($objectName); |
3705 |
|
# Find the field references for this object. |
3706 |
|
while ($filterString =~ m/$mappedName\(([^)]*)\)/g) { |
3707 |
|
# At this point, $1 contains the field name, and the current position |
3708 |
|
# is set immediately after the final parenthesis. We pull out the name of |
3709 |
|
# the field and the position and length of the field reference as a whole. |
3710 |
|
my $fieldName = $1; |
3711 |
|
my $len = $nameLength + length $fieldName; |
3712 |
|
my $pos = pos($filterString) - $len; |
3713 |
|
# Insure the field exists. |
3714 |
|
if (!exists $fieldList->{$fieldName}) { |
3715 |
|
Confess("Field $fieldName not found for object $objectName."); |
3716 |
|
} else { |
3717 |
|
Trace("Processing $fieldName at position $pos.") if T(4); |
3718 |
|
# Get the field's relation. |
3719 |
|
my $relationName = $fieldList->{$fieldName}->{relation}; |
3720 |
|
# Now we have a secondary relation. We need to insure it matches the |
3721 |
|
# mapped name of the primary relation. First we peel off the suffix |
3722 |
|
# from the mapped name. |
3723 |
|
my $mappingSuffix = substr $mappedName, length($objectName); |
3724 |
|
# Put the mapping suffix onto the relation name to get the |
3725 |
|
# mapped relation name. |
3726 |
|
my $mappedRelationName = "$relationName$mappingSuffix"; |
3727 |
|
# Insure the relation is in the FROM clause. |
3728 |
|
if (!exists $fromNames{$mappedRelationName}) { |
3729 |
|
# Add the relation to the FROM clause. |
3730 |
|
if ($mappedRelationName eq $relationName) { |
3731 |
|
# The name is un-mapped, so we add it without |
3732 |
|
# any frills. |
3733 |
|
$suffix .= ", $relationName"; |
3734 |
|
push @joinWhere, "$objectName.id = $relationName.id"; |
3735 |
|
} else { |
3736 |
|
# Here we have a mapping situation. |
3737 |
|
$suffix .= ", $relationName $mappedRelationName"; |
3738 |
|
push @joinWhere, "$mappedRelationName.id = $mappedName.id"; |
3739 |
|
} |
3740 |
|
# Denote we have this relation available for future fields. |
3741 |
|
$fromNames{$mappedRelationName} = 1; |
3742 |
|
} |
3743 |
|
# Form an SQL field reference from the relation name and the field name. |
3744 |
|
my $sqlReference = "$mappedRelationName." . _FixName($fieldName); |
3745 |
|
# Put it into the filter string in place of the old value. |
3746 |
|
substr($filterString, $pos, $len) = $sqlReference; |
3747 |
|
# Reposition the search. |
3748 |
|
pos $filterString = $pos + length $sqlReference; |
3749 |
|
} |
3750 |
|
} |
3751 |
|
} |
3752 |
|
} |
3753 |
|
# The next step is to join the objects together. We only need to do this if there |
3754 |
|
# is more than one object in the object list. We start with the first object and |
3755 |
|
# run through the objects after it. Note also that we make a safety copy of the |
3756 |
|
# list before running through it, because we shift off the first object before |
3757 |
|
# processing the rest. |
3758 |
|
my @mappedObjectList = @mappedNameList; |
3759 |
|
my $lastMappedObject = shift @mappedObjectList; |
3760 |
|
# Get the join table. |
3761 |
|
my $joinTable = $self->{_metaData}->{Joins}; |
3762 |
|
# Loop through the object list. |
3763 |
|
for my $thisMappedObject (@mappedObjectList) { |
3764 |
|
# Look for a join using the real object names. |
3765 |
|
my $lastObject = $mappedNameHash{$lastMappedObject}; |
3766 |
|
my $thisObject = $mappedNameHash{$thisMappedObject}; |
3767 |
|
my $joinKey = "$lastObject/$thisObject"; |
3768 |
|
if (!exists $joinTable->{$joinKey}) { |
3769 |
|
# Here there's no join, so we throw an error. |
3770 |
|
Confess("No join exists to connect from $lastMappedObject to $thisMappedObject."); |
3771 |
|
} else { |
3772 |
|
# Get the join clause. |
3773 |
|
my $unMappedJoin = $joinTable->{$joinKey}; |
3774 |
|
# Fix the names. |
3775 |
|
$unMappedJoin =~ s/$lastObject/$lastMappedObject/; |
3776 |
|
$unMappedJoin =~ s/$thisObject/$thisMappedObject/; |
3777 |
|
push @joinWhere, $unMappedJoin; |
3778 |
|
# Save this object as the last object for the next iteration. |
3779 |
|
$lastMappedObject = $thisMappedObject; |
3780 |
|
} |
3781 |
|
} |
3782 |
|
# Now we need to handle the whole ORDER BY / LIMIT thing. The important part |
3783 |
|
# here is we want the filter clause to be empty if there's no WHERE filter. |
3784 |
|
# We'll put the ORDER BY / LIMIT clauses in the following variable. |
3785 |
|
my $orderClause = ""; |
3786 |
|
# This is only necessary if we have a filter string in which the ORDER BY |
3787 |
|
# and LIMIT clauses can live. |
3788 |
|
if ($filterString) { |
3789 |
|
# Locate the ORDER BY or LIMIT verbs (if any). We use a non-greedy |
3790 |
|
# operator so that we find the first occurrence of either verb. |
3791 |
|
if ($filterString =~ m/^(.*?)\s*(ORDER BY|LIMIT)/g) { |
3792 |
|
# Here we have an ORDER BY or LIMIT verb. Split it off of the filter string. |
3793 |
|
my $pos = pos $filterString; |
3794 |
|
$orderClause = $2 . substr($filterString, $pos); |
3795 |
|
$filterString = $1; |
3796 |
|
} |
3797 |
|
} |
3798 |
|
# All the things that are supposed to be in the WHERE clause of the |
3799 |
|
# SELECT command need to be put into @joinWhere so we can string them |
3800 |
|
# together. We begin with the match clause. This is important, |
3801 |
|
# because the match clause's parameter mark must precede any parameter |
3802 |
|
# marks in the filter string. |
3803 |
|
if ($matchClause) { |
3804 |
|
push @joinWhere, $matchClause; |
3805 |
|
} |
3806 |
|
# Add the filter string. We put it in parentheses to avoid operator |
3807 |
|
# precedence problems with the match clause or the joins. |
3808 |
|
if ($filterString) { |
3809 |
|
Trace("Filter string is \"$filterString\".") if T(4); |
3810 |
|
push @joinWhere, "($filterString)"; |
3811 |
|
} |
3812 |
|
# String it all together into a big filter clause. |
3813 |
|
if (@joinWhere) { |
3814 |
|
$suffix .= " WHERE " . join(' AND ', @joinWhere); |
3815 |
|
} |
3816 |
|
# Add the sort or limit clause (if any). |
3817 |
|
if ($orderClause) { |
3818 |
|
$suffix .= " $orderClause"; |
3819 |
|
} |
3820 |
|
# Return the suffix, the mapped name list, and the mapped name hash. |
3821 |
|
return ($suffix, \@mappedNameList, \%mappedNameHash); |
3822 |
|
} |
3823 |
|
|
3824 |
|
=head3 _GetStatementHandle |
3825 |
|
|
3826 |
|
This method will prepare and execute an SQL query, returning the statement handle. |
3827 |
|
The main reason for doing this here is so that everybody who does SQL queries gets |
3828 |
|
the benefit of tracing. |
3829 |
|
|
3830 |
|
This is an instance method. |
3831 |
|
|
3832 |
|
=over 4 |
3833 |
|
|
3834 |
|
=item command |
3835 |
|
|
3836 |
|
Command to prepare and execute. |
3837 |
|
|
3838 |
|
=item params |
3839 |
|
|
3840 |
|
Reference to a list of the values to be substituted in for the parameter marks. |
3841 |
|
|
3842 |
|
=item RETURN |
3843 |
|
|
3844 |
|
Returns a prepared and executed statement handle from which the caller can extract |
3845 |
|
results. |
3846 |
|
|
3847 |
|
=back |
3848 |
|
|
3849 |
|
=cut |
3850 |
|
|
3851 |
|
sub _GetStatementHandle { |
3852 |
|
# Get the parameters. |
3853 |
|
my ($self, $command, $params) = @_; |
3854 |
|
# Trace the query. |
3855 |
|
Trace("SQL query: $command") if T(SQL => 3); |
3856 |
|
Trace("PARMS: '" . (join "', '", @{$params}) . "'") if (T(SQL => 4) && (@{$params} > 0)); |
3857 |
|
# Get the database handle. |
3858 |
|
my $dbh = $self->{_dbh}; |
3859 |
|
# Prepare the command. |
3860 |
|
my $sth = $dbh->prepare_command($command); |
3861 |
|
# Execute it with the parameters bound in. |
3862 |
|
$sth->execute(@{$params}) || Confess("SELECT error: " . $sth->errstr()); |
3863 |
|
# Return the statement handle. |
3864 |
|
return $sth; |
3865 |
|
} |
3866 |
|
|
3867 |
|
=head3 _GetLoadStats |
3868 |
|
|
3869 |
|
Return a blank statistics object for use by the load methods. |
3870 |
|
|
3871 |
|
This is a static method. |
3872 |
|
|
3873 |
|
=cut |
3874 |
|
|
3875 |
|
sub _GetLoadStats{ |
3876 |
|
return Stats->new(); |
3877 |
} |
} |
3878 |
|
|
3879 |
=head3 DumpRelation |
=head3 _DumpRelation |
3880 |
|
|
3881 |
Dump the specified relation's to the specified output file in tab-delimited format. |
Dump the specified relation to the specified output file in tab-delimited format. |
3882 |
|
|
3883 |
This is an instance method. |
This is an instance method. |
3884 |
|
|
3926 |
close DTXOUT; |
close DTXOUT; |
3927 |
} |
} |
3928 |
|
|
3929 |
=head3 GetStructure |
=head3 _GetStructure |
3930 |
|
|
3931 |
Get the data structure for a specified entity or relationship. |
Get the data structure for a specified entity or relationship. |
3932 |
|
|
3965 |
return $retVal; |
return $retVal; |
3966 |
} |
} |
3967 |
|
|
3968 |
=head3 GetRelationTable |
|
3969 |
|
|
3970 |
|
=head3 _GetRelationTable |
3971 |
|
|
3972 |
Get the list of relations for a specified entity or relationship. |
Get the list of relations for a specified entity or relationship. |
3973 |
|
|
3996 |
return $objectData->{Relations}; |
return $objectData->{Relations}; |
3997 |
} |
} |
3998 |
|
|
3999 |
=head3 GetFieldTable |
=head3 _ValidateFieldNames |
|
|
|
|
Get the field structure for a specified entity or relationship. |
|
|
|
|
|
This is an instance method. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item objectName |
|
|
|
|
|
Name of the desired entity or relationship. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
The table containing the field descriptors for the specified object. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub _GetFieldTable { |
|
|
# Get the parameters. |
|
|
my ($self, $objectName) = @_; |
|
|
# Get the descriptor from the metadata. |
|
|
my $objectData = $self->_GetStructure($objectName); |
|
|
# Return the object's field table. |
|
|
return $objectData->{Fields}; |
|
|
} |
|
|
|
|
|
=head3 ValidateFieldNames |
|
4000 |
|
|
4001 |
Determine whether or not the field names are valid. A description of the problems with the names |
Determine whether or not the field names are valid. A description of the problems with the names |
4002 |
will be written to the standard error output. If there is an error, this method will abort. This is |
will be written to the standard error output. If there is an error, this method will abort. This is |
4023 |
for my $object (values %{$metadata->{$section}}) { |
for my $object (values %{$metadata->{$section}}) { |
4024 |
# Loop through the object's fields. |
# Loop through the object's fields. |
4025 |
for my $fieldName (keys %{$object->{Fields}}) { |
for my $fieldName (keys %{$object->{Fields}}) { |
4026 |
# Now we make some initial validations. |
# If this field name is invalid, set the return value to zero |
4027 |
if ($fieldName =~ /--/) { |
# so we know we encountered an error. |
4028 |
# Here we have a doubled minus sign. |
if (! ValidateFieldName($fieldName)) { |
|
print STDERR "Field name $fieldName has a doubled hyphen.\n"; |
|
|
$retVal = 0; |
|
|
} elsif ($fieldName !~ /^[A-Za-z]/) { |
|
|
# Here the field name is missing the initial letter. |
|
|
print STDERR "Field name $fieldName does not begin with a letter.\n"; |
|
|
$retVal = 0; |
|
|
} else { |
|
|
# Strip out the minus signs. Everything remaining must be a letter |
|
|
# or digit. |
|
|
my $strippedName = $fieldName; |
|
|
$strippedName =~ s/-//g; |
|
|
if ($strippedName !~ /^[A-Za-z0-9]+$/) { |
|
|
print STDERR "Field name $fieldName contains illegal characters.\n"; |
|
4029 |
$retVal = 0; |
$retVal = 0; |
4030 |
} |
} |
4031 |
} |
} |
4032 |
} |
} |
4033 |
} |
} |
|
} |
|
4034 |
# If an error was found, fail. |
# If an error was found, fail. |
4035 |
if ($retVal == 0) { |
if ($retVal == 0) { |
4036 |
Confess("Errors found in field names."); |
Confess("Errors found in field names."); |
4037 |
} |
} |
4038 |
} |
} |
4039 |
|
|
4040 |
=head3 LoadRelation |
=head3 _LoadRelation |
4041 |
|
|
4042 |
Load a relation from the data in a tab-delimited disk file. The load will only take place if a disk |
Load a relation from the data in a tab-delimited disk file. The load will only take place if a disk |
4043 |
file with the same name as the relation exists in the specified directory. |
file with the same name as the relation exists in the specified directory. |
4097 |
return $retVal; |
return $retVal; |
4098 |
} |
} |
4099 |
|
|
4100 |
=head3 LoadMetaData |
|
4101 |
|
=head3 _LoadMetaData |
4102 |
|
|
4103 |
This method loads the data describing this database from an XML file into a metadata structure. |
This method loads the data describing this database from an XML file into a metadata structure. |
4104 |
The resulting structure is a set of nested hash tables containing all the information needed to |
The resulting structure is a set of nested hash tables containing all the information needed to |
4123 |
sub _LoadMetaData { |
sub _LoadMetaData { |
4124 |
# Get the parameters. |
# Get the parameters. |
4125 |
my ($filename) = @_; |
my ($filename) = @_; |
4126 |
Trace("Reading Sprout DBD from $filename.") if T(2); |
Trace("Reading DBD from $filename.") if T(2); |
4127 |
# Slurp the XML file into a variable. Extensive use of options is used to insure we |
# Slurp the XML file into a variable. Extensive use of options is used to insure we |
4128 |
# get the exact structure we want. |
# get the exact structure we want. |
4129 |
my $metadata = XML::Simple::XMLin($filename, |
my $metadata = ReadMetaXML($filename); |
|
GroupTags => { Relationships => 'Relationship', |
|
|
Entities => 'Entity', |
|
|
Fields => 'Field', |
|
|
Indexes => 'Index', |
|
|
IndexFields => 'IndexField'}, |
|
|
KeyAttr => { Relationship => 'name', |
|
|
Entity => 'name', |
|
|
Field => 'name'}, |
|
|
ForceArray => ['Field', 'Index', 'IndexField'], |
|
|
ForceContent => 1, |
|
|
NormalizeSpace => 2 |
|
|
); |
|
|
Trace("XML metadata loaded from file $filename.") if T(1); |
|
4130 |
# Before we go any farther, we need to validate the field and object names. If an error is found, |
# Before we go any farther, we need to validate the field and object names. If an error is found, |
4131 |
# the method below will fail. |
# the method below will fail. |
4132 |
_ValidateFieldNames($metadata); |
_ValidateFieldNames($metadata); |
4256 |
my $count = 0; |
my $count = 0; |
4257 |
for my $index (@{$indexList}) { |
for my $index (@{$indexList}) { |
4258 |
# Add this index to the index table. |
# Add this index to the index table. |
4259 |
_AddIndex("idx$relationName$count", $relation, $index); |
_AddIndex("idx$count", $relation, $index); |
4260 |
# Increment the counter so that the next index has a different name. |
# Increment the counter so that the next index has a different name. |
4261 |
$count++; |
$count++; |
4262 |
} |
} |
4273 |
_FixupFields($relationshipStructure, $relationshipName, 2, 3); |
_FixupFields($relationshipStructure, $relationshipName, 2, 3); |
4274 |
# Format a description for the FROM field. |
# Format a description for the FROM field. |
4275 |
my $fromEntity = $relationshipStructure->{from}; |
my $fromEntity = $relationshipStructure->{from}; |
4276 |
my $fromComment = "<b>id</b> of the source <b><a href=\"#$fromEntity\">$fromEntity</a></b>."; |
my $fromComment = "[b]id[/b] of the source [b][link #$fromEntity]$fromEntity\[/link][/b]."; |
4277 |
# Get the FROM entity's key type. |
# Get the FROM entity's key type. |
4278 |
my $fromType = $entityList->{$fromEntity}->{keyType}; |
my $fromType = $entityList->{$fromEntity}->{keyType}; |
4279 |
# Add the FROM field. |
# Add the FROM field. |
4283 |
PrettySort => 1}); |
PrettySort => 1}); |
4284 |
# Format a description for the TO field. |
# Format a description for the TO field. |
4285 |
my $toEntity = $relationshipStructure->{to}; |
my $toEntity = $relationshipStructure->{to}; |
4286 |
my $toComment = "<b>id</b> of the target <b><a href=\"#$toEntity\">$toEntity</a></b>."; |
my $toComment = "[b]id[/b] of the target [b][link #$toEntity]$toEntity\[/link][/b]."; |
4287 |
# Get the TO entity's key type. |
# Get the TO entity's key type. |
4288 |
my $toType = $entityList->{$toEntity}->{keyType}; |
my $toType = $entityList->{$toEntity}->{keyType}; |
4289 |
# Add the TO field. |
# Add the TO field. |
4323 |
# Determine if this relationship has our entity in one of its link fields. |
# Determine if this relationship has our entity in one of its link fields. |
4324 |
my $fromEntity = $relationship->{from}; |
my $fromEntity = $relationship->{from}; |
4325 |
my $toEntity = $relationship->{to}; |
my $toEntity = $relationship->{to}; |
4326 |
Trace("Join check for relationship $relationshipName from $fromEntity to $toEntity.") if T(4); |
Trace("Join check for relationship $relationshipName from $fromEntity to $toEntity.") if T(Joins => 4); |
4327 |
if ($fromEntity eq $entityName) { |
if ($fromEntity eq $entityName) { |
4328 |
if ($toEntity eq $entityName) { |
if ($toEntity eq $entityName) { |
4329 |
# Here the relationship is recursive. |
# Here the relationship is recursive. |
4412 |
return $metadata; |
return $metadata; |
4413 |
} |
} |
4414 |
|
|
4415 |
=head3 CreateRelationshipIndex |
=head3 _CreateRelationshipIndex |
4416 |
|
|
4417 |
Create an index for a relationship's relation. |
Create an index for a relationship's relation. |
4418 |
|
|
4454 |
$newIndex->{Unique} = 'true'; |
$newIndex->{Unique} = 'true'; |
4455 |
} |
} |
4456 |
# Add the index to the relation. |
# Add the index to the relation. |
4457 |
_AddIndex("idx$relationshipName$indexKey", $relationStructure, $newIndex); |
_AddIndex("idx$indexKey", $relationStructure, $newIndex); |
4458 |
} |
} |
4459 |
|
|
4460 |
=head3 AddIndex |
=head3 _AddIndex |
4461 |
|
|
4462 |
Add an index to a relation structure. |
Add an index to a relation structure. |
4463 |
|
|
4503 |
$relationStructure->{Indexes}->{$indexName} = $newIndex; |
$relationStructure->{Indexes}->{$indexName} = $newIndex; |
4504 |
} |
} |
4505 |
|
|
4506 |
=head3 FixupFields |
=head3 _FixupFields |
4507 |
|
|
4508 |
This method fixes the field list for an entity or relationship. It will add the caller-specified |
This method fixes the field list for an entity or relationship. It will add the caller-specified |
4509 |
relation name to fields that do not have a name and set the C<PrettySort> value as specified. |
relation name to fields that do not have a name and set the C<PrettySort> value as specified. |
4541 |
# Here it doesn't, so we create a new one. |
# Here it doesn't, so we create a new one. |
4542 |
$structure->{Fields} = { }; |
$structure->{Fields} = { }; |
4543 |
} else { |
} else { |
4544 |
# Here we have a field list. Loop through its fields. |
# Here we have a field list. We need to track the searchable fields, so we |
4545 |
|
# create a list for stashing them. |
4546 |
|
my @textFields = (); |
4547 |
|
# Loop through the fields. |
4548 |
my $fieldStructures = $structure->{Fields}; |
my $fieldStructures = $structure->{Fields}; |
4549 |
for my $fieldName (keys %{$fieldStructures}) { |
for my $fieldName (keys %{$fieldStructures}) { |
4550 |
Trace("Processing field $fieldName of $defaultRelationName.") if T(4); |
Trace("Processing field $fieldName of $defaultRelationName.") if T(4); |
4553 |
my $type = $fieldData->{type}; |
my $type = $fieldData->{type}; |
4554 |
# Plug in a relation name if it is needed. |
# Plug in a relation name if it is needed. |
4555 |
Tracer::MergeOptions($fieldData, { relation => $defaultRelationName }); |
Tracer::MergeOptions($fieldData, { relation => $defaultRelationName }); |
4556 |
# Plug in a data generator if we need one. |
# Check for searchability. |
4557 |
if (!exists $fieldData->{DataGen}) { |
if ($fieldData->{searchable}) { |
4558 |
# The data generator will use the default for the field's type. |
# Only allow this for a primary relation. |
4559 |
$fieldData->{DataGen} = { content => $TypeTable{$type}->{dataGen} }; |
if ($fieldData->{relation} ne $defaultRelationName) { |
4560 |
|
Confess("Field $fieldName of $defaultRelationName is in secondary relations and cannot be searchable."); |
4561 |
|
} else { |
4562 |
|
push @textFields, $fieldName; |
4563 |
|
} |
4564 |
} |
} |
|
# Plug in the defaults for the optional data generation parameters. |
|
|
Tracer::MergeOptions($fieldData->{DataGen}, { testCount => 1, pass => 0 }); |
|
4565 |
# Add the PrettySortValue. |
# Add the PrettySortValue. |
4566 |
$fieldData->{PrettySort} = (($type eq "text") ? $textPrettySortValue : $prettySortValue); |
$fieldData->{PrettySort} = (($type eq "text") ? $textPrettySortValue : $prettySortValue); |
4567 |
} |
} |
4568 |
|
# If there are searchable fields, remember the fact. |
4569 |
|
if (@textFields) { |
4570 |
|
$structure->{searchFields} = \@textFields; |
4571 |
|
} |
4572 |
} |
} |
4573 |
} |
} |
4574 |
|
|
4575 |
=head3 FixName |
=head3 _FixName |
4576 |
|
|
4577 |
Fix the incoming field name so that it is a legal SQL column name. |
Fix the incoming field name so that it is a legal SQL column name. |
4578 |
|
|
4601 |
return $fieldName; |
return $fieldName; |
4602 |
} |
} |
4603 |
|
|
4604 |
=head3 FixNames |
=head3 _FixNames |
4605 |
|
|
4606 |
Fix all the field names in a list. |
Fix all the field names in a list. |
4607 |
|
|
4632 |
return @result; |
return @result; |
4633 |
} |
} |
4634 |
|
|
4635 |
=head3 AddField |
=head3 _AddField |
4636 |
|
|
4637 |
Add a field to a field list. |
Add a field to a field list. |
4638 |
|
|
4667 |
$fieldList->{$fieldName} = $fieldStructure; |
$fieldList->{$fieldName} = $fieldStructure; |
4668 |
} |
} |
4669 |
|
|
4670 |
=head3 ReOrderRelationTable |
=head3 _ReOrderRelationTable |
4671 |
|
|
4672 |
This method will take a relation table and re-sort it according to the implicit ordering of the |
This method will take a relation table and re-sort it according to the implicit ordering of the |
4673 |
C<PrettySort> property. Instead of a hash based on field names, it will return a list of fields. |
C<PrettySort> property. Instead of a hash based on field names, it will return a list of fields. |
4728 |
|
|
4729 |
} |
} |
4730 |
|
|
4731 |
=head3 IsPrimary |
=head3 _IsPrimary |
4732 |
|
|
4733 |
Return TRUE if a specified relation is a primary relation, else FALSE. A relation is primary |
Return TRUE if a specified relation is a primary relation, else FALSE. A relation is primary |
4734 |
if it has the same name as an entity or relationship. |
if it has the same name as an entity or relationship. |
4764 |
return $retVal; |
return $retVal; |
4765 |
} |
} |
4766 |
|
|
4767 |
=head3 FindRelation |
=head3 _FindRelation |
4768 |
|
|
4769 |
Return the descriptor for the specified relation. |
Return the descriptor for the specified relation. |
4770 |
|
|
4795 |
|
|
4796 |
=head2 HTML Documentation Utility Methods |
=head2 HTML Documentation Utility Methods |
4797 |
|
|
4798 |
=head3 ComputeRelationshipSentence |
=head3 _ComputeRelationshipSentence |
4799 |
|
|
4800 |
The relationship sentence consists of the relationship name between the names of the |
The relationship sentence consists of the relationship name between the names of the |
4801 |
two related entities and an arity indicator. |
two related entities and an arity indicator. |
4833 |
return $result; |
return $result; |
4834 |
} |
} |
4835 |
|
|
4836 |
=head3 ComputeRelationshipHeading |
=head3 _ComputeRelationshipHeading |
4837 |
|
|
4838 |
The relationship heading is the L<relationship sentence|/ComputeRelationshipSentence> with the entity |
The relationship heading is the L<relationship sentence|/ComputeRelationshipSentence> with the entity |
4839 |
names hyperlinked to the appropriate entity sections of the document. |
names hyperlinked to the appropriate entity sections of the document. |
4870 |
return $result; |
return $result; |
4871 |
} |
} |
4872 |
|
|
4873 |
=head3 ShowRelationTable |
=head3 _ShowRelationTable |
4874 |
|
|
4875 |
Generate the HTML string for a particular relation. The relation's data will be formatted as an HTML |
Generate the HTML string for a particular relation. The relation's data will be formatted as an HTML |
4876 |
table with three columns-- the field name, the field type, and the field description. |
table with three columns-- the field name, the field type, and the field description. |
4920 |
$htmlString .= "<li><b>Index $fullName</b>\n<ul>\n"; |
$htmlString .= "<li><b>Index $fullName</b>\n<ul>\n"; |
4921 |
# Add any note text. |
# Add any note text. |
4922 |
if (my $note = $indexData->{Notes}) { |
if (my $note = $indexData->{Notes}) { |
4923 |
$htmlString .= "<li>" . _HTMLNote($note->{content}) . "</li>\n"; |
$htmlString .= "<li>" . HTMLNote($note->{content}) . "</li>\n"; |
4924 |
} |
} |
4925 |
# Add the fiield list. |
# Add the fiield list. |
4926 |
$htmlString .= "<li><i>" . join(', ', @{$indexData->{IndexFields}}) . "</i></li>\n"; |
$htmlString .= "<li><i>" . join(', ', @{$indexData->{IndexFields}}) . "</i></li>\n"; |
4931 |
$htmlString .= "</ul>\n"; |
$htmlString .= "</ul>\n"; |
4932 |
} |
} |
4933 |
|
|
4934 |
=head3 OpenFieldTable |
=head3 _OpenFieldTable |
4935 |
|
|
4936 |
This method creates the header string for the field table generated by L</ShowMetaData>. |
This method creates the header string for the field table generated by L</ShowMetaData>. |
4937 |
|
|
4956 |
return _OpenTable($tablename, 'Field', 'Type', 'Description'); |
return _OpenTable($tablename, 'Field', 'Type', 'Description'); |
4957 |
} |
} |
4958 |
|
|
4959 |
=head3 OpenTable |
=head3 _OpenTable |
4960 |
|
|
4961 |
This method creates the header string for an HTML table. |
This method creates the header string for an HTML table. |
4962 |
|
|
4986 |
# Compute the number of columns. |
# Compute the number of columns. |
4987 |
my $colCount = @colNames; |
my $colCount = @colNames; |
4988 |
# Generate the title row. |
# Generate the title row. |
4989 |
my $htmlString = "<p><table border=\"2\"><tr><td colspan=\"$colCount\" align=\"center\">$tablename</td></tr>\n"; |
my $htmlString = "<table border=\"2\"><tr><td colspan=\"$colCount\" align=\"center\">$tablename</td></tr>\n"; |
4990 |
# Loop through the columns, adding the column header rows. |
# Loop through the columns, adding the column header rows. |
4991 |
$htmlString .= "<tr>"; |
$htmlString .= "<tr>"; |
4992 |
for my $colName (@colNames) { |
for my $colName (@colNames) { |
4996 |
return $htmlString; |
return $htmlString; |
4997 |
} |
} |
4998 |
|
|
4999 |
=head3 CloseTable |
=head3 _CloseTable |
5000 |
|
|
5001 |
This method returns the HTML for closing a table. |
This method returns the HTML for closing a table. |
5002 |
|
|
5005 |
=cut |
=cut |
5006 |
|
|
5007 |
sub _CloseTable { |
sub _CloseTable { |
5008 |
return "</table></p>\n"; |
return "</table>\n"; |
5009 |
} |
} |
5010 |
|
|
5011 |
=head3 ShowField |
=head3 _ShowField |
5012 |
|
|
5013 |
This method returns the HTML for displaying a row of field information in a field table. |
This method returns the HTML for displaying a row of field information in a field table. |
5014 |
|
|
5035 |
my $htmlString = "<tr><th align=\"left\">$fieldData->{name}</th><td>$fieldData->{type}</td>"; |
my $htmlString = "<tr><th align=\"left\">$fieldData->{name}</th><td>$fieldData->{type}</td>"; |
5036 |
# If we have content, add it as a third column. |
# If we have content, add it as a third column. |
5037 |
if (exists $fieldData->{Notes}) { |
if (exists $fieldData->{Notes}) { |
5038 |
$htmlString .= "<td>" . _HTMLNote($fieldData->{Notes}->{content}) . "</td>"; |
$htmlString .= "<td>" . HTMLNote($fieldData->{Notes}->{content}) . "</td>"; |
5039 |
} |
} |
5040 |
# Close off the row. |
# Close off the row. |
5041 |
$htmlString .= "</tr>\n"; |
$htmlString .= "</tr>\n"; |
5043 |
return $htmlString; |
return $htmlString; |
5044 |
} |
} |
5045 |
|
|
|
=head3 HTMLNote |
|
|
|
|
|
Convert a note or comment to HTML by replacing some bulletin-board codes with HTML. The codes |
|
|
supported are C<[b]> for B<bold>, C<[i]> for I<italics>, and C<[p]> for a new paragraph. |
|
|
Except for C<[p]>, all the codes are closed by slash-codes. So, for |
|
|
example, C<[b]Feature[/b]> displays the string C<Feature> in boldface. |
|
|
|
|
|
This is a static method. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item dataString |
|
|
|
|
|
String to convert to HTML. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
An HTML string derived from the input string. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub _HTMLNote { |
|
|
# Get the parameter. |
|
|
my ($dataString) = @_; |
|
|
# Substitute the codes. |
|
|
$dataString =~ s!\[(/?[bi])\]!<$1>!g; |
|
|
$dataString =~ s!\[p\]!</p><p>!g; |
|
|
# Return the result. |
|
|
return $dataString; |
|
|
} |
|
|
|
|
|
=head2 Data Generation Utilities |
|
|
|
|
|
=head3 IntGen |
|
|
|
|
|
C<< my $integer = IntGen($min, $max); >> |
|
|
|
|
|
Returns a random number between the specified minimum and maximum (inclusive). |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item min |
|
|
|
|
|
Minimum permissible return value. |
|
|
|
|
|
=item max |
|
|
|
|
|
Maximum permissible return value. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a value no lower than the minimum and no greater than the maximum. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub IntGen { |
|
|
# Get the parameters. |
|
|
my ($min, $max) = @_; |
|
|
# Determine the range of possible values. Note we put some space well above the |
|
|
# maximum value to give it a fighting chance of apppearing in the list. |
|
|
my $span = $max + 0.99 - $min; |
|
|
# Create an integer in the range. |
|
|
my $retVal = $min + int(rand($span)); |
|
|
# Return the result. |
|
|
return $retVal; |
|
|
} |
|
|
|
|
|
=head3 RandChar |
|
|
|
|
|
C<< my $char = RandChar($sourceString); >> |
|
|
|
|
|
Select a random character from a string. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item sourceString |
|
|
|
|
|
String from which the random character should be selected. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a single character from the incoming string. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub RandChar { |
|
|
# Get the parameter. |
|
|
my ($sourceString) = @_; |
|
|
# Select a random character. |
|
|
my $retVal = IntGen(0, (length $sourceString) - 1); |
|
|
# Return it. |
|
|
return substr($sourceString, $retVal, 1); |
|
|
} |
|
|
|
|
|
=head3 RandChars |
|
|
|
|
|
C<< my $string = RandChars($sourceString, $length); >> |
|
|
|
|
|
Create a string from characters taken from a source string. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item sourceString |
|
|
|
|
|
String from which the random characters should be selected. |
|
|
|
|
|
=item length |
|
|
|
|
|
Number of characters to put in the output string. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a string of the specified length consisting of characters taken from the |
|
|
source string. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub RandChars { |
|
|
# Get the parameters. |
|
|
my ($sourceString, $length) = @_; |
|
|
# Call RandChar repeatedly to generate the string. |
|
|
my $retVal = ""; |
|
|
for (my $i = 0; $i < $length; $i++) { |
|
|
$retVal .= RandChar($sourceString); |
|
|
} |
|
|
# Return the result. |
|
|
return $retVal; |
|
|
} |
|
|
|
|
|
=head3 RandParam |
|
|
|
|
|
C<< my $value = RandParam($parm1, $parm2, ... $parmN); >> |
|
|
|
|
|
Return a randomly-selected value from the parameter list. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item parm1, parm2, ... parmN |
|
|
|
|
|
List of values of which one will be selected. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a randomly-chosen value from the specified list. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub RandParam { |
|
|
# Get the parameter. |
|
|
my @parms = @_; |
|
|
# Choose a random parameter from the list. |
|
|
my $chosenIndex = IntGen(0, $#parms); |
|
|
return $parms[$chosenIndex]; |
|
|
} |
|
|
|
|
|
=head3 StringGen |
|
|
|
|
|
C<< my $string = StringGen($pattern1, $pattern2, ... $patternN); >> |
|
|
|
|
|
Returns a random string derived from a randomly-chosen format pattern. The pattern |
|
|
can either be a number (indicating the number of characters desired, or the letter |
|
|
C<P> followed by a picture. The picture should contain C<A> when a letter is desired, |
|
|
C<9> when a digit is desired, C<V> when a vowel is desired, C<K> when a consonant is |
|
|
desired, and C<X> when a letter or a digit is desired. Any other character will be |
|
|
translated as a literal. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item pattern1, pattern2, ... patternN |
|
|
|
|
|
List of patterns to be used to generate string values. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
A single string generated from a pattern. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub StringGen { |
|
|
# Get the parameters. |
|
|
my @patterns = @_; |
|
|
# Choose the appropriate pattern. |
|
|
my $chosenPattern = RandParam(@patterns); |
|
|
# Declare the return variable. |
|
|
my $retVal = ""; |
|
|
# Determine whether this is a count or a picture pattern. |
|
|
if ($chosenPattern =~ m/^\d+/) { |
|
|
# Here we have a count. Get the string of source characters. |
|
|
my $letterString = $PictureTable{'X'}; |
|
|
my $stringLen = length $letterString; |
|
|
# Save the number of characters we have to generate. |
|
|
my $charsLeft = $chosenPattern; |
|
|
# Loop until the return variable is full. |
|
|
while ($charsLeft > 0) { |
|
|
# Generate a random position in the soruce string. |
|
|
my $stringIndex = IntGen(0, $stringLen - 1); |
|
|
# Compute the number of characters to pull out of the source string. |
|
|
my $chunkSize = $stringLen - $stringIndex; |
|
|
if ($chunkSize > $charsLeft) { $chunkSize = $charsLeft; } |
|
|
# Stuff this chunk into the return value. |
|
|
$retVal .= substr($letterString, $stringIndex, $chunkSize); |
|
|
# Record the data moved. |
|
|
$charsLeft -= $chunkSize; |
|
|
} |
|
|
} elsif ($chosenPattern =~ m/^P/) { |
|
|
# Here we have a picture string. We will move through the picture one |
|
|
# character at a time generating data. |
|
|
for (my $i = 1; $i < length $chosenPattern; $i++) { |
|
|
# Get this picture character. |
|
|
my $chr = substr($chosenPattern, $i, 1); |
|
|
# Check to see if the picture char is one we recognize. |
|
|
if (exists $PictureTable{$chr}) { |
|
|
# Choose a random character from the available values for this |
|
|
# picture character. |
|
|
$retVal .= RandChar($PictureTable{$chr}); |
|
|
} else { |
|
|
# Copy in the picture character as a literal. |
|
|
$retVal .= $chr; |
|
|
} |
|
|
} |
|
|
} else { |
|
|
# Here we have neither a picture string or a letter count, so we treat |
|
|
# the string as a literal. |
|
|
$retVal = $chosenPattern; |
|
|
} |
|
|
# Return the string formed. |
|
|
return $retVal; |
|
|
} |
|
|
|
|
|
=head3 DateGen |
|
|
|
|
|
C<< my $date = DateGen($startDayOffset, $endDayOffset, $minutes); >> |
|
|
|
|
|
Return a numeric timestamp within the specified range of days with the specified minute |
|
|
value. The range of days is specified relevant to the current day. Thus, the call |
|
|
|
|
|
C<< my $date = DateGen(-1, 5, 720); >> |
|
|
|
|
|
will return a timestamp at noon (72 minutes past midnight) sometime during the week that |
|
|
began on the preceding day. If you want a random minute of the day, simply combine with |
|
|
a call to L</IntGen>, as follows. |
|
|
|
|
|
C<< my $date = DateGen(-1, 5, IntGen(0, 1439)); >> |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item startDayOffset |
|
|
|
|
|
The earliest day that can be returned, relative to the current day. |
|
|
|
|
|
=item endDayOffset |
|
|
|
|
|
The latest day that can be returned, related to the current day. |
|
|
|
|
|
=item minutes |
|
|
|
|
|
Number of minutes into the selected day that should be used. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub DateGen { |
|
|
# Get the parameters. |
|
|
my ($startDayOffset, $endDayOffset, $minutes) = @_; |
|
|
# Get midnight of the current day. |
|
|
my $now = time(); |
|
|
my ($sec, $min, $hour) = localtime($now); |
|
|
my $today = $now - (($hour * 60 + $min) * 60 + $sec); |
|
|
# Compute the day we want. |
|
|
my $newDay = IntGen($startDayOffset, $endDayOffset) * 86400 + $today; |
|
|
# Add the minutes. |
|
|
my $retVal = $newDay + $minutes * 60; |
|
|
# Return the result. |
|
|
return $retVal; |
|
|
} |
|
|
|
|
|
=head3 FloatGen |
|
|
|
|
|
C<< my $number = FloatGen($min, $max); >> |
|
|
|
|
|
Return a random floating-point number greater than or equal to the specified minimum and |
|
|
less than the specified maximum. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item min |
|
|
|
|
|
Minimum permissible value for the number returned. |
|
|
|
|
|
=item max |
|
|
|
|
|
Maximum permissible value for the number returned. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a floating-point number anywhere in the specified range. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub FloatGen { |
|
|
# Get the parameters. |
|
|
my ($min, $max) = @_; |
|
|
# Generate the result. |
|
|
my $retVal = rand($max - $min) + $min; |
|
|
return $retVal; |
|
|
} |
|
|
|
|
|
=head3 ListGen |
|
|
|
|
|
C<< my @list = ListGen($pattern, $count); >> |
|
|
|
|
|
Return a list containing a fixed number of randomly-generated strings. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item pattern |
|
|
|
|
|
A pattern (in the form expected by L</StringGen>) that should be used to generate the |
|
|
strings in the list. |
|
|
|
|
|
=item count |
|
|
|
|
|
The number of list entries to generate. |
|
|
|
|
|
=item RETURN |
|
|
|
|
|
Returns a list consisting of the specified number of strings. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub ListGen { |
|
|
# Get the parameters. |
|
|
my ($pattern, $count) = @_; |
|
|
# Generate the list. |
|
|
my @retVal = (); |
|
|
for (my $i = 0; $i < $count; $i++) { |
|
|
push @retVal, StringGen($pattern); |
|
|
} |
|
|
# Return it. |
|
|
return @retVal; |
|
|
} |
|
|
|
|
5046 |
1; |
1; |