6 |
use Data::Dumper; |
use Data::Dumper; |
7 |
use XML::Simple; |
use XML::Simple; |
8 |
use DBQuery; |
use DBQuery; |
9 |
use DBObject; |
use ERDBObject; |
10 |
use Stats; |
use Stats; |
11 |
use Time::HiRes qw(gettimeofday); |
use Time::HiRes qw(gettimeofday); |
12 |
use Digest::MD5 qw(md5_base64); |
use Digest::MD5 qw(md5_base64); |
13 |
use FIG; |
use CGI; |
14 |
|
use WikiTools; |
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 |
218 |
index will be created for each relation with at least one searchable field in it. |
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. |
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 in an |
232 |
be from the primary relation. The alternate indexes assist in ordering results |
index must all be from the same relation. The alternate indexes assist in searching |
233 |
from a query. A relationship can have up to two indexes-- a I<to-index> and a |
on fields other than the entity ID. A relationship has at least two indexes-- a I<to-index> and a |
234 |
I<from-index>. These order the results when crossing the relationship. For |
I<from-index> that 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 |
236 |
from-index would order the contigs of a ganome, and the to-index would order |
from-index would order the contigs of a ganome, and the to-index would order |
237 |
the genomes of a contig. A relationship's index must specify only fields in |
the genomes of a contig. In addition, it can have zero or more alternate |
238 |
|
indexes. A relationship's index must specify only fields in |
239 |
the relationship. |
the relationship. |
240 |
|
|
241 |
The indexes for an entity must be listed inside the B<Indexes> tag. The from-index |
The alternate indexes for an entity or relationship must be listed inside the B<Indexes> tag. |
242 |
of a relationship is specified using the B<FromIndex> tag; the to-index is specified |
The from-index of a relationship is specified using the B<FromIndex> tag; the to-index is |
243 |
using the B<ToIndex> tag. |
specified using the B<ToIndex> tag. |
244 |
|
|
245 |
Each index can contain a B<Notes> tag. In addition, it will have an B<IndexFields> |
Each index can contain a B<Notes> tag. In addition, it will have an B<IndexFields> |
246 |
tag containing the B<IndexField> tags. These specify, in order, the fields used in |
tag containing the B<IndexField> tags. These specify, in order, the fields used in |
258 |
|
|
259 |
=back |
=back |
260 |
|
|
261 |
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 |
262 |
|
have a B<Unique> attribute. If specified, the index will be generated as a unique |
263 |
|
index. |
264 |
|
|
265 |
=head3 Object and Field Names |
=head3 Object and Field Names |
266 |
|
|
304 |
|
|
305 |
A relationship is described by the C<Relationship> tag. Within a relationship, |
A relationship is described by the C<Relationship> tag. Within a relationship, |
306 |
there can be a C<Notes> tag, a C<Fields> tag containing the intersection data |
there can be a C<Notes> tag, a C<Fields> tag containing the intersection data |
307 |
fields, a C<FromIndex> tag containing the from-index, and a C<ToIndex> tag containing |
fields, a C<FromIndex> tag containing the from-index, a C<ToIndex> tag containing |
308 |
the to-index. |
the to-index, and an C<Indexes> tag containing the alternate indexes. |
309 |
|
|
310 |
The C<Relationship> tag has the following attributes. |
The C<Relationship> tag has the following attributes. |
311 |
|
|
338 |
|
|
339 |
# 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. |
340 |
# "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 |
341 |
# 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 |
342 |
# 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, |
343 |
# record sizes. "sort" is the key modifier for the sort command. |
# and "indexMod", if non-zero, is the number of characters to use when the field is specified in an |
344 |
my %TypeTable = ( char => { sqlType => 'CHAR(1)', maxLen => 1, avgLen => 1, sort => "", dataGen => "StringGen('A')" }, |
# index |
345 |
int => { sqlType => 'INTEGER', maxLen => 20, avgLen => 4, sort => "n", dataGen => "IntGen(0, 99999999)" }, |
my %TypeTable = ( char => { sqlType => 'CHAR(1)', maxLen => 1, avgLen => 1, sort => "", |
346 |
counter => { sqlType => 'INTEGER UNSIGNED', maxLen => 20, avgLen => 4, sort => "n", dataGen => "IntGen(0, 99999999)" }, |
indexMod => 0, notes => "single ASCII character"}, |
347 |
string => { sqlType => 'VARCHAR(255)', maxLen => 255, avgLen => 100, sort => "", dataGen => "StringGen(IntGen(10,250))" }, |
int => { sqlType => 'INTEGER', maxLen => 20, avgLen => 4, sort => "n", |
348 |
text => { sqlType => 'TEXT', maxLen => 1000000000, avgLen => 500, sort => "", dataGen => "StringGen(IntGen(80,1000))" }, |
indexMod => 0, notes => "signed 32-bit integer"}, |
349 |
date => { sqlType => 'BIGINT', maxLen => 80, avgLen => 8, sort => "n", dataGen => "DateGen(-7, 7, IntGen(0,1400))" }, |
counter => { sqlType => 'INTEGER UNSIGNED', maxLen => 20, avgLen => 4, sort => "n", |
350 |
float => { sqlType => 'DOUBLE PRECISION', maxLen => 40, avgLen => 8, sort => "g", dataGen => "FloatGen(0.0, 100.0)" }, |
indexMod => 0, notes => "unsigned 32-bit integer"}, |
351 |
boolean => { sqlType => 'SMALLINT', maxLen => 1, avgLen => 1, sort => "n", dataGen => "IntGen(0, 1)" }, |
string => { sqlType => 'VARCHAR(255)', maxLen => 255, avgLen => 100, sort => "", |
352 |
|
indexMod => 0, notes => "character string, 0 to 255 characters"}, |
353 |
|
text => { sqlType => 'TEXT', maxLen => 1000000000, avgLen => 500, sort => "", |
354 |
|
indexMod => 255, notes => "character string, nearly unlimited length, only first 255 characters are indexed"}, |
355 |
|
date => { sqlType => 'BIGINT', maxLen => 80, avgLen => 8, sort => "n", |
356 |
|
indexMod => 0, notes => "signed, 64-bit integer"}, |
357 |
|
float => { sqlType => 'DOUBLE PRECISION', maxLen => 40, avgLen => 8, sort => "g", |
358 |
|
indexMod => 0, notes => "64-bit double precision floating-point number"}, |
359 |
|
boolean => { sqlType => 'SMALLINT', maxLen => 1, avgLen => 1, sort => "n", |
360 |
|
indexMod => 0, notes => "boolean value: 0 if false, 1 if true"}, |
361 |
'hash-string' => |
'hash-string' => |
362 |
{ sqlType => 'VARCHAR(22)', maxLen => 22, avgLen => 22, sort => "", dataGen => "SringGen(22)" }, |
{ sqlType => 'VARCHAR(22)', maxLen => 22, avgLen => 22, sort => "", |
363 |
|
indexMod => 0, notes => "string stored in digested form, used for certain types of key fields"}, |
364 |
'id-string' => |
'id-string' => |
365 |
{ sqlType => 'VARCHAR(25)', maxLen => 25, avgLen => 25, sort => "", dataGen => "SringGen(22)" }, |
{ sqlType => 'VARCHAR(25)', maxLen => 25, avgLen => 25, sort => "", |
366 |
|
indexMod => 0, notes => "character string, 0 to 25 characters"}, |
367 |
'key-string' => |
'key-string' => |
368 |
{ sqlType => 'VARCHAR(40)', maxLen => 40, avgLen => 10, sort => "", dataGen => "StringGen(IntGen(10,40))" }, |
{ sqlType => 'VARCHAR(40)', maxLen => 40, avgLen => 10, sort => "", |
369 |
|
indexMod => 0, notes => "character string, 0 to 40 characters"}, |
370 |
'name-string' => |
'name-string' => |
371 |
{ sqlType => 'VARCHAR(80)', maxLen => 80, avgLen => 40, sort => "", dataGen => "StringGen(IntGen(10,80))" }, |
{ sqlType => 'VARCHAR(80)', maxLen => 80, avgLen => 40, sort => "", |
372 |
|
indexMod => 0, notes => "character string, 0 to 80 characters"}, |
373 |
'medium-string' => |
'medium-string' => |
374 |
{ sqlType => 'VARCHAR(160)', maxLen => 160, avgLen => 40, sort => "", dataGen => "StringGen(IntGen(10,160))" }, |
{ sqlType => 'VARCHAR(160)', maxLen => 160, avgLen => 40, sort => "", |
375 |
|
indexMod => 0, notes => "character string, 0 to 160 characters"}, |
376 |
|
'long-string' => |
377 |
|
{ sqlType => 'VARCHAR(500)', maxLen => 500, avglen => 255, sort => "", |
378 |
|
indexMod => 0, notes => "character string, 0 to 500 characters"}, |
379 |
); |
); |
380 |
|
|
381 |
# Table translating arities into natural language. |
# Table translating arities into natural language. |
384 |
'MM' => 'many-to-many' |
'MM' => 'many-to-many' |
385 |
); |
); |
386 |
|
|
387 |
# Table for interpreting string patterns. |
# Options for XML input and output. |
388 |
|
|
389 |
|
my %XmlOptions = (GroupTags => { Relationships => 'Relationship', |
390 |
|
Entities => 'Entity', |
391 |
|
Fields => 'Field', |
392 |
|
Indexes => 'Index', |
393 |
|
IndexFields => 'IndexField', |
394 |
|
Issues => 'Issue', |
395 |
|
Shapes => 'Shape' |
396 |
|
}, |
397 |
|
KeyAttr => { Relationship => 'name', |
398 |
|
Entity => 'name', |
399 |
|
Field => 'name', |
400 |
|
Shape => 'name' |
401 |
|
}, |
402 |
|
SuppressEmpty => 1, |
403 |
|
); |
404 |
|
|
405 |
my %PictureTable = ( 'A' => "abcdefghijklmnopqrstuvwxyz", |
my %XmlInOpts = ( |
406 |
'9' => "0123456789", |
ForceArray => [qw(Field Index IndexField Relationship Entity Shape)], |
407 |
'X' => "abcdefghijklmnopqrstuvwxyz0123456789", |
ForceContent => 1, |
408 |
'V' => "aeiou", |
NormalizeSpace => 2, |
409 |
'K' => "bcdfghjklmnoprstvwxyz" |
); |
410 |
|
my %XmlOutOpts = ( |
411 |
|
RootName => 'Database', |
412 |
|
XMLDecl => 1, |
413 |
); |
); |
414 |
|
|
415 |
=head2 Public Methods |
=head2 Public Methods |
416 |
|
|
417 |
=head3 new |
=head3 new |
418 |
|
|
419 |
C<< my $database = ERDB->new($dbh, $metaFileName); >> |
my $database = ERDB->new($dbh, $metaFileName); |
420 |
|
|
421 |
Create a new ERDB object. |
Create a new ERDB object. |
422 |
|
|
436 |
|
|
437 |
sub new { |
sub new { |
438 |
# Get the parameters. |
# Get the parameters. |
439 |
my ($class, $dbh, $metaFileName, $options) = @_; |
my ($class, $dbh, $metaFileName, %options) = @_; |
440 |
# Load the meta-data. |
# Load the meta-data. |
441 |
my $metaData = _LoadMetaData($metaFileName); |
my $metaData = _LoadMetaData($metaFileName); |
442 |
# Create the object. |
# Create the object. |
450 |
|
|
451 |
=head3 ShowMetaData |
=head3 ShowMetaData |
452 |
|
|
453 |
C<< $erdb->ShowMetaData($fileName); >> |
$erdb->ShowMetaData($fileName); |
454 |
|
|
455 |
This method outputs a description of the database. This description can be used to help users create |
This method outputs a description of the database. This description can be used to help users create |
456 |
the data to be loaded into the relations. |
the data to be loaded into the relations. |
491 |
|
|
492 |
=head3 DisplayMetaData |
=head3 DisplayMetaData |
493 |
|
|
494 |
C<< my $html = $erdb->DisplayMetaData(); >> |
my $html = $erdb->DisplayMetaData(); |
495 |
|
|
496 |
Return an HTML description of the database. This description can be used to help users create |
Return an HTML description of the database. This description can be used to help users create |
497 |
the data to be loaded into the relations and form queries. The output is raw includable HTML |
the data to be loaded into the relations and form queries. The output is raw includable HTML |
552 |
my $entityData = $entityList->{$key}; |
my $entityData = $entityList->{$key}; |
553 |
# If there's descriptive text, display it. |
# If there's descriptive text, display it. |
554 |
if (my $notes = $entityData->{Notes}) { |
if (my $notes = $entityData->{Notes}) { |
555 |
$retVal .= "<p>" . _HTMLNote($notes->{content}) . "</p>\n"; |
$retVal .= "<p>" . HTMLNote($notes->{content}) . "</p>\n"; |
556 |
} |
} |
557 |
# 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. |
558 |
|
my $relCount = keys %{$relationshipList}; |
559 |
|
if ($relCount > 0) { |
560 |
|
# First, we set up the relationship subsection. |
561 |
$retVal .= "<h4>Relationships for <b>$key</b></h4>\n<ul>\n"; |
$retVal .= "<h4>Relationships for <b>$key</b></h4>\n<ul>\n"; |
562 |
# Loop through the relationships. |
# Loop through the relationships. |
563 |
for my $relationship (sort keys %{$relationshipList}) { |
for my $relationship (sort keys %{$relationshipList}) { |
573 |
} |
} |
574 |
# Close off the relationship list. |
# Close off the relationship list. |
575 |
$retVal .= "</ul>\n"; |
$retVal .= "</ul>\n"; |
576 |
|
} |
577 |
# Get the entity's relations. |
# Get the entity's relations. |
578 |
my $relationList = $entityData->{Relations}; |
my $relationList = $entityData->{Relations}; |
579 |
# Create a header for the relation subsection. |
# Create a header for the relation subsection. |
613 |
$retVal .= "</p>\n"; |
$retVal .= "</p>\n"; |
614 |
# If there are notes on this relationship, display them. |
# If there are notes on this relationship, display them. |
615 |
if (my $notes = $relationshipStructure->{Notes}) { |
if (my $notes = $relationshipStructure->{Notes}) { |
616 |
$retVal .= "<p>" . _HTMLNote($notes->{content}) . "</p>\n"; |
$retVal .= "<p>" . HTMLNote($notes->{content}) . "</p>\n"; |
617 |
} |
} |
618 |
# Generate the relationship's relation table. |
# Generate the relationship's relation table. |
619 |
my $htmlString = _ShowRelationTable($key, $relationshipStructure->{Relations}->{$key}); |
my $htmlString = _ShowRelationTable($key, $relationshipStructure->{Relations}->{$key}); |
647 |
|
|
648 |
=head3 DumpMetaData |
=head3 DumpMetaData |
649 |
|
|
650 |
C<< $erdb->DumpMetaData(); >> |
$erdb->DumpMetaData(); |
651 |
|
|
652 |
Return a dump of the metadata structure. |
Return a dump of the metadata structure. |
653 |
|
|
660 |
return Data::Dumper::Dumper($self->{_metaData}); |
return Data::Dumper::Dumper($self->{_metaData}); |
661 |
} |
} |
662 |
|
|
663 |
|
=head3 GenerateWikiData |
664 |
|
|
665 |
|
my @wikiLines = $erdb->GenerateWikiData(); |
666 |
|
|
667 |
|
Build a description of the database for the wiki. The database will be |
668 |
|
organized into a single page, with sections for each entity and relationship. |
669 |
|
The return value is a list of text lines. |
670 |
|
|
671 |
|
=cut |
672 |
|
|
673 |
|
sub GenerateWikiData { |
674 |
|
# Get the parameters. |
675 |
|
my ($self) = @_; |
676 |
|
# We'll build the wiki text in here. |
677 |
|
my @retVal = (); |
678 |
|
# Get the metadata object. |
679 |
|
my $metadata = $self->{_metaData}; |
680 |
|
# Get the title string. This will become the page name. |
681 |
|
my $title = $metadata->{Title}->{content}; |
682 |
|
# Get the entity and relationship lists. |
683 |
|
my $entityList = $metadata->{Entities}; |
684 |
|
my $relationshipList = $metadata->{Relationships}; |
685 |
|
my $shapeList = $metadata->{Shapes}; |
686 |
|
# Start with the introductory text. |
687 |
|
push @retVal, WikiTools::Heading(2, "Introduction"); |
688 |
|
if (my $notes = $metadata->{Notes}) { |
689 |
|
push @retVal, WikiNote($notes->{content}); |
690 |
|
} |
691 |
|
# Generate issue list. |
692 |
|
if (my $issues = $metadata->{Issues}) { |
693 |
|
push @retVal, WikiTools::Heading(3, 'Issues'); |
694 |
|
push @retVal, WikiTools::List(map { $_->{content} } @{$issues}); |
695 |
|
} |
696 |
|
# Start the entity section. |
697 |
|
push @retVal, WikiTools::Heading(2, "Entities"); |
698 |
|
# Loop through the entities. Note that unlike the situation with HTML, we |
699 |
|
# don't need to generate the table of contents manually, just the data |
700 |
|
# itself. |
701 |
|
for my $key (sort keys %$entityList) { |
702 |
|
# Create a header for this entity. |
703 |
|
push @retVal, "", WikiTools::Heading(3, $key); |
704 |
|
# Get the entity data. |
705 |
|
my $entityData = $entityList->{$key}; |
706 |
|
# Plant the notes here, if there are any. |
707 |
|
push @retVal, _ObjectNotes($entityData); |
708 |
|
# Now we list the entity's relationships (if any). First, we build a list |
709 |
|
# of the relationships relevant to this entity. |
710 |
|
my @rels = (); |
711 |
|
for my $rel (sort keys %$relationshipList) { |
712 |
|
my $relStructure = $relationshipList->{$rel}; |
713 |
|
if ($relStructure->{from} eq $key || $relStructure->{to} eq $key) { |
714 |
|
# Get the relationship sentence. |
715 |
|
my $relSentence = _ComputeRelationshipSentence($rel, $relStructure); |
716 |
|
# Linkify it. |
717 |
|
my $linkedRel = WikiTools::LinkMarkup("#$rel", $rel); |
718 |
|
$relSentence =~ s/$rel/$linkedRel/; |
719 |
|
push @rels, $relSentence; |
720 |
|
} |
721 |
|
} |
722 |
|
# Add the relationships as a Wiki list. |
723 |
|
push @retVal, WikiTools::List(@rels); |
724 |
|
# Get the entity's relations. |
725 |
|
my $relationList = $entityData->{Relations}; |
726 |
|
# Loop through the relations, displaying them. |
727 |
|
for my $relation (sort keys %{$relationList}) { |
728 |
|
my $wikiString = _WikiRelationTable($relation, $relationList->{$relation}); |
729 |
|
push @retVal, $wikiString; |
730 |
|
} |
731 |
|
} |
732 |
|
# Now the entities are documented. Next we do the relationships. |
733 |
|
push @retVal, WikiTools::Heading(2, "Relationships"); |
734 |
|
for my $key (sort keys %$relationshipList) { |
735 |
|
my $relationshipData = $relationshipList->{$key}; |
736 |
|
# Create the relationship heading. |
737 |
|
push @retVal, WikiTools::Heading(3, $key); |
738 |
|
# Describe the relationship arity. Note there's a bit of trickiness involving recursive |
739 |
|
# many-to-many relationships. In a normal many-to-many we use two sentences to describe |
740 |
|
# the arity (one for each direction). This is a bad idea for a recursive relationship, |
741 |
|
# since both sentences will say the same thing. |
742 |
|
my $arity = $relationshipData->{arity}; |
743 |
|
my $fromEntity = $relationshipData->{from}; |
744 |
|
my $toEntity = $relationshipData->{to}; |
745 |
|
my @listElements = (); |
746 |
|
my $boldCode = WikiTools::BoldCode(); |
747 |
|
if ($arity eq "11") { |
748 |
|
push @listElements, "Each $boldCode$fromEntity$boldCode relates to at most one $boldCode$toEntity$boldCode."; |
749 |
|
} else { |
750 |
|
push @listElements, "Each $boldCode$fromEntity$boldCode relates to multiple $boldCode${toEntity}s$boldCode."; |
751 |
|
if ($arity eq "MM" && $fromEntity ne $toEntity) { |
752 |
|
push @listElements, "Each $boldCode$toEntity$boldCode relates to multiple $boldCode${fromEntity}s$boldCode."; |
753 |
|
} |
754 |
|
} |
755 |
|
push @retVal, WikiTools::List(@listElements); |
756 |
|
# Plant the notes here, if there are any. |
757 |
|
push @retVal, _ObjectNotes($relationshipData); |
758 |
|
# Finally, the relationship table. |
759 |
|
my $wikiString = _WikiRelationTable($key, $relationshipData->{Relations}->{$key}); |
760 |
|
push @retVal, $wikiString; |
761 |
|
} |
762 |
|
# Now loop through the miscellaneous shapes. |
763 |
|
if ($shapeList) { |
764 |
|
push @retVal, WikiTools::Heading(2, "Miscellaneous"); |
765 |
|
for my $shape (sort keys %$shapeList) { |
766 |
|
push @retVal, WikiTools::Heading(3, $shape); |
767 |
|
my $shapeData = $shapeList->{$shape}; |
768 |
|
push @retVal, _ObjectNotes($shapeData); |
769 |
|
} |
770 |
|
} |
771 |
|
# All done. Return the lines. |
772 |
|
return @retVal; |
773 |
|
} |
774 |
|
|
775 |
|
|
776 |
|
=head3 CreatePPO |
777 |
|
|
778 |
|
ERDB::CreatePPO($erdbXMLFile, $ppoXMLFile); |
779 |
|
|
780 |
|
Create a PPO XML file from an ERDB data definition XML file. At the |
781 |
|
current time, the PPO XML file can be used to create a database with |
782 |
|
similar functionality. Eventually, the PPO will be able to use the |
783 |
|
created XML to access the live ERDB database. |
784 |
|
|
785 |
|
=over 4 |
786 |
|
|
787 |
|
=item erdbXMLFile |
788 |
|
|
789 |
|
Name of the XML data definition file for the ERDB database. This |
790 |
|
file must exist. |
791 |
|
|
792 |
|
=item ppoXMLFile |
793 |
|
|
794 |
|
Output file for the PPO XML definition. If this file exists, it |
795 |
|
will be overwritten. |
796 |
|
|
797 |
|
=back |
798 |
|
|
799 |
|
=cut |
800 |
|
|
801 |
|
sub CreatePPO { |
802 |
|
# Get the parameters. |
803 |
|
my ($erdbXMLFile, $ppoXMLFile) = @_; |
804 |
|
# First, we want to slurp in the ERDB XML file in its raw form. |
805 |
|
my $xml = ReadMetaXML($erdbXMLFile); |
806 |
|
# Create a variable to hold all of the objects in the PPO project. |
807 |
|
my @objects = (); |
808 |
|
# Get the relationship hash. |
809 |
|
my $relationships = $xml->{Relationships}; |
810 |
|
# Loop through the entities. |
811 |
|
my $entities = $xml->{Entities}; |
812 |
|
for my $entityName (keys %{$entities}) { |
813 |
|
# Get the entity's data structures. |
814 |
|
my $entityObject = $entities->{$entityName}; |
815 |
|
# We put the object's fields in here, according to their type. |
816 |
|
my (@object_refs, @scalars, @indexes, @arrays); |
817 |
|
# Create the ID field for the entity. We get the key type from the |
818 |
|
# entity object and compute the corresponding SQL type. |
819 |
|
my $type = $TypeTable{$entityObject->{keyType}}->{sqlType}; |
820 |
|
push @scalars, { label => 'id', type => $type }; |
821 |
|
# Loop through the entity fields. |
822 |
|
for my $fieldName ( keys %{$entityObject->{Fields}} ) { |
823 |
|
# Get the field object. |
824 |
|
my $fieldObject = $entityObject->{Fields}->{$fieldName}; |
825 |
|
# Convert it to a scalar tag. |
826 |
|
my $scalar = _CreatePPOField($fieldName, $fieldObject); |
827 |
|
# If we have a relation, this field is stored in an array. |
828 |
|
# otherwise, it is a scalar. The array tag has scalars |
829 |
|
# stored as an XML array. In ERDB, there is only ever one, |
830 |
|
# but PPO can have more. |
831 |
|
my $relation = $fieldObject->{relation}; |
832 |
|
if ($relation) { |
833 |
|
push @arrays, { scalar => [$scalar] }; |
834 |
|
} else { |
835 |
|
push @scalars, $scalar; |
836 |
|
} |
837 |
|
} |
838 |
|
# Loop through the relationships. If this entity is the to-entity |
839 |
|
# on a relationship of 1M arity, then it is implemented as a PPO |
840 |
|
# object reference. |
841 |
|
for my $relationshipName (keys %{$relationships}) { |
842 |
|
# Get the relationship data. |
843 |
|
my $relationshipData = $relationships->{$relationshipName}; |
844 |
|
# If we have a from for this entity and an arity of 1M, we |
845 |
|
# have an object reference. |
846 |
|
if ($relationshipData->{to} eq $entityName && |
847 |
|
$relationshipData->{arity} eq '1M') { |
848 |
|
# Build the object reference tag. |
849 |
|
push @object_refs, { label => $relationshipName, |
850 |
|
type => $relationshipData->{from} }; |
851 |
|
} |
852 |
|
} |
853 |
|
# Create the indexes. |
854 |
|
my $indexList = $entityObject->{Indexes}; |
855 |
|
push @indexes, map { _CreatePPOIndex($_) } @{$indexList}; |
856 |
|
# Build the object XML tree. |
857 |
|
my $object = { label => $entityName, |
858 |
|
object_ref => \@object_refs, |
859 |
|
scalar => \@scalars, |
860 |
|
index => \@indexes, |
861 |
|
array => \@arrays |
862 |
|
}; |
863 |
|
# Push the object onto the objects list. |
864 |
|
push @objects, $object; |
865 |
|
} |
866 |
|
# Loop through the relationships, searching for MMs. The 1Ms were |
867 |
|
# already handled by the entity search above. |
868 |
|
for my $relationshipName (keys %{$relationships}) { |
869 |
|
# Get this relationship's object. |
870 |
|
my $relationshipObject = $relationships->{$relationshipName}; |
871 |
|
# Only proceed if it's many-to-many. |
872 |
|
if ($relationshipObject->{arity} eq 'MM') { |
873 |
|
# Create the tag lists for the relationship object. |
874 |
|
my (@object_refs, @scalars, @indexes); |
875 |
|
# The relationship will be created as an object with object |
876 |
|
# references for its links to the participating entities. |
877 |
|
my %links = ( from_link => $relationshipObject->{from}, |
878 |
|
to_link => $relationshipObject->{to} ); |
879 |
|
for my $link (keys %links) { |
880 |
|
# Create an object_ref tag for this piece of the |
881 |
|
# relationship (from or to). |
882 |
|
my $object_ref = { label => $link, |
883 |
|
type => $links{$link} }; |
884 |
|
push @object_refs, $object_ref; |
885 |
|
} |
886 |
|
# Loop through the intersection data fields, creating scalar tags. |
887 |
|
# There are no fancy array tags in a relationship. |
888 |
|
for my $fieldName (keys %{$relationshipObject->{Fields}}) { |
889 |
|
my $fieldObject = $relationshipObject->{Fields}->{$fieldName}; |
890 |
|
push @scalars, _CreatePPOField($fieldName, $fieldObject); |
891 |
|
} |
892 |
|
# Finally, the indexes: currently we cannot support the to-index and |
893 |
|
# from-index in PPO, so we just process the alternate indexes. |
894 |
|
my $indexList = $relationshipObject->{Indexes}; |
895 |
|
push @indexes, map { _CreatePPOIndex($_) } @{$indexList}; |
896 |
|
# Wrap up all the stuff about this relationship. |
897 |
|
my $object = { label => $relationshipName, |
898 |
|
scalar => \@scalars, |
899 |
|
object_ref => \@object_refs, |
900 |
|
index => \@indexes |
901 |
|
}; |
902 |
|
# Push it into the object list. |
903 |
|
push @objects, $object; |
904 |
|
} |
905 |
|
} |
906 |
|
# Compute a title. |
907 |
|
my $title; |
908 |
|
if ($erdbXMLFile =~ /(\/|^)([^\/]+)DBD\.xml/) { |
909 |
|
# Here we have a standard file name we can use for a title. |
910 |
|
$title = $2; |
911 |
|
} else { |
912 |
|
# Here the file name is non-standard, so we carve up the |
913 |
|
# database title. |
914 |
|
$title = $xml->{Title}->{content}; |
915 |
|
$title =~ s/\s\.,//g; |
916 |
|
} |
917 |
|
# Wrap up the XML as a project. |
918 |
|
my $ppoXML = { project => { label => $title, |
919 |
|
object => \@objects }}; |
920 |
|
# Write out the results. |
921 |
|
my $ppoString = XML::Simple::XMLout($ppoXML, |
922 |
|
AttrIndent => 1, |
923 |
|
KeepRoot => 1); |
924 |
|
Tracer::PutFile($ppoXMLFile, [ $ppoString ]); |
925 |
|
} |
926 |
|
|
927 |
|
=head3 FindIndexForEntity |
928 |
|
|
929 |
|
my $indexFound = ERDB::FindIndexForEntity($xml, $entityName, $attributeName); |
930 |
|
|
931 |
|
This method locates the entry in an entity's index list that begins with the |
932 |
|
specified attribute name. If the entity has no index list, one will be |
933 |
|
created. This method works on raw XML, not a live ERDB object. |
934 |
|
|
935 |
|
=over 4 |
936 |
|
|
937 |
|
=item xml |
938 |
|
|
939 |
|
The raw XML structure defining the database. |
940 |
|
|
941 |
|
=item entityName |
942 |
|
|
943 |
|
The name of the relevant entity. |
944 |
|
|
945 |
|
=item attributeName |
946 |
|
|
947 |
|
The name of the attribute relevant to the search. |
948 |
|
|
949 |
|
=item RETURN |
950 |
|
|
951 |
|
The numerical index in the index list of the index entry for the specified entity and |
952 |
|
attribute, or C<undef> if no such index exists. |
953 |
|
|
954 |
|
=back |
955 |
|
|
956 |
|
=cut |
957 |
|
|
958 |
|
sub FindIndexForEntity { |
959 |
|
# Get the parameters. |
960 |
|
my ($xml, $entityName, $attributeName) = @_; |
961 |
|
# Declare the return variable. |
962 |
|
my $retVal; |
963 |
|
# Get the named entity. |
964 |
|
my $entityData = $xml->{Entities}->{$entityName}; |
965 |
|
if (! $entityData) { |
966 |
|
Confess("Entity $entityName not found in DBD structure."); |
967 |
|
} else { |
968 |
|
# Insure it has an index list. |
969 |
|
if (! exists $entityData->{Indexes}) { |
970 |
|
$entityData->{Indexes} = []; |
971 |
|
} else { |
972 |
|
# Search for the desired index. |
973 |
|
my $indexList = $entityData->{Indexes}; |
974 |
|
my $n = scalar @{$indexList}; |
975 |
|
Trace("Searching $n indexes in index list for $entityName.") if T(2); |
976 |
|
# We use an indexed FOR here because we're returning an |
977 |
|
# index number instead of an object. We do THAT so we can |
978 |
|
# delete the index from the list if needed. |
979 |
|
for (my $i = 0; $i < $n && !defined($retVal); $i++) { |
980 |
|
my $index = $indexList->[$i]; |
981 |
|
my $fields = $index->{IndexFields}; |
982 |
|
# Technically this IF should be safe (that is, we are guaranteed |
983 |
|
# the existence of a "$fields->[0]"), because when we load the XML |
984 |
|
# we have SuppressEmpty specified. |
985 |
|
if ($fields->[0]->{name} eq $attributeName) { |
986 |
|
$retVal = $i; |
987 |
|
} |
988 |
|
} |
989 |
|
} |
990 |
|
} |
991 |
|
Trace("Index for $attributeName of $entityName found at position $retVal.") if defined($retVal) && T(3); |
992 |
|
Trace("Index for $attributeName not found in $entityName.") if !defined($retVal) && T(3); |
993 |
|
# Return the result. |
994 |
|
return $retVal; |
995 |
|
} |
996 |
|
|
997 |
=head3 CreateTables |
=head3 CreateTables |
998 |
|
|
999 |
C<< $erdb->CreateTables(); >> |
$erdb->CreateTables(); |
1000 |
|
|
1001 |
This method creates the tables for the database from the metadata structure loaded by the |
This method creates the tables for the database from the metadata structure loaded by the |
1002 |
constructor. It is expected this function will only be used on rare occasions, when the |
constructor. It is expected this function will only be used on rare occasions, when the |
1013 |
# Loop through the relations. |
# Loop through the relations. |
1014 |
for my $relationName (@relNames) { |
for my $relationName (@relNames) { |
1015 |
# Create a table for this relation. |
# Create a table for this relation. |
1016 |
$self->CreateTable($relationName); |
$self->CreateTable($relationName, 1); |
1017 |
Trace("Relation $relationName created.") if T(2); |
Trace("Relation $relationName created.") if T(2); |
1018 |
} |
} |
1019 |
} |
} |
1020 |
|
|
1021 |
=head3 CreateTable |
=head3 CreateTable |
1022 |
|
|
1023 |
C<< $erdb->CreateTable($tableName, $indexFlag, $estimatedRows); >> |
$erdb->CreateTable($tableName, $indexFlag, $estimatedRows); |
1024 |
|
|
1025 |
Create the table for a relation and optionally create its indexes. |
Create the table for a relation and optionally create its indexes. |
1026 |
|
|
1062 |
# Push the result into the field list. |
# Push the result into the field list. |
1063 |
push @fieldList, $fieldString; |
push @fieldList, $fieldString; |
1064 |
} |
} |
|
# If this is a root table, add the "new_record" flag. It defaults to 0, so |
|
|
if ($rootFlag) { |
|
|
push @fieldList, "new_record $TypeTable{boolean}->{sqlType} NOT NULL DEFAULT 0"; |
|
|
} |
|
1065 |
# Convert the field list into a comma-delimited string. |
# Convert the field list into a comma-delimited string. |
1066 |
my $fieldThing = join(', ', @fieldList); |
my $fieldThing = join(', ', @fieldList); |
1067 |
# Insure the table is not already there. |
# Insure the table is not already there. |
1072 |
my $estimation = undef; |
my $estimation = undef; |
1073 |
if ($estimatedRows) { |
if ($estimatedRows) { |
1074 |
$estimation = [$self->EstimateRowSize($relationName), $estimatedRows]; |
$estimation = [$self->EstimateRowSize($relationName), $estimatedRows]; |
1075 |
|
Trace("$estimation->[1] rows of $estimation->[0] bytes each.") if T(3); |
1076 |
} |
} |
1077 |
# Create the table. |
# Create the table. |
1078 |
Trace("Creating table $relationName: $fieldThing") if T(2); |
Trace("Creating table $relationName: $fieldThing") if T(2); |
1087 |
|
|
1088 |
=head3 VerifyFields |
=head3 VerifyFields |
1089 |
|
|
1090 |
C<< my $count = $erdb->VerifyFields($relName, \@fieldList); >> |
my $count = $erdb->VerifyFields($relName, \@fieldList); |
1091 |
|
|
1092 |
Run through the list of proposed field values, insuring that all the character fields are |
Run through the list of proposed field values, insuring that all the character fields are |
1093 |
below the maximum length. If any fields are too long, they will be truncated in place. |
below the maximum length. If any fields are too long, they will be truncated in place. |
1130 |
my $oldString = $fieldList->[$i]; |
my $oldString = $fieldList->[$i]; |
1131 |
if (length($oldString) > $maxLen) { |
if (length($oldString) > $maxLen) { |
1132 |
# Here it's too big, so we truncate it. |
# Here it's too big, so we truncate it. |
1133 |
Trace("Truncating field $i in relation $relName to $maxLen characters from \"$oldString\".") if T(1); |
Trace("Truncating field $i ($fieldTypes->[$i]->{name}) in relation $relName to $maxLen characters from \"$oldString\".") if T(1); |
1134 |
$fieldList->[$i] = substr $oldString, 0, $maxLen; |
$fieldList->[$i] = substr $oldString, 0, $maxLen; |
1135 |
$retVal++; |
$retVal++; |
1136 |
} |
} |
1142 |
|
|
1143 |
=head3 DigestFields |
=head3 DigestFields |
1144 |
|
|
1145 |
C<< $erdb->DigestFields($relName, $fieldList); >> |
$erdb->DigestFields($relName, $fieldList); |
1146 |
|
|
1147 |
Digest the strings in the field list that correspond to data type C<hash-string> in the |
Digest the strings in the field list that correspond to data type C<hash-string> in the |
1148 |
specified relation. |
specified relation. |
1182 |
|
|
1183 |
=head3 DigestKey |
=head3 DigestKey |
1184 |
|
|
1185 |
C<< my $digested = $erdb->DigestKey($keyValue); >> |
my $digested = $erdb->DigestKey($keyValue); |
1186 |
|
|
1187 |
Return the digested value of a symbolic key. The digested value can then be plugged into a |
Return the digested value of a symbolic key. The digested value can then be plugged into a |
1188 |
key-based search into a table with key-type hash-string. |
key-based search into a table with key-type hash-string. |
1215 |
|
|
1216 |
=head3 CreateIndex |
=head3 CreateIndex |
1217 |
|
|
1218 |
C<< $erdb->CreateIndex($relationName); >> |
$erdb->CreateIndex($relationName); |
1219 |
|
|
1220 |
Create the indexes for a relation. If a table is being loaded from a large source file (as |
Create the indexes for a relation. If a table is being loaded from a large source file (as |
1221 |
is the case in L</LoadTable>), it is sometimes best to create the indexes after the load. |
is the case in L</LoadTable>), it is sometimes best to create the indexes after the load. |
1236 |
for my $indexName (keys %{$indexHash}) { |
for my $indexName (keys %{$indexHash}) { |
1237 |
my $indexData = $indexHash->{$indexName}; |
my $indexData = $indexHash->{$indexName}; |
1238 |
# Get the index's field list. |
# Get the index's field list. |
1239 |
my @fieldList = _FixNames(@{$indexData->{IndexFields}}); |
my @rawFields = @{$indexData->{IndexFields}}; |
1240 |
|
# Get a hash of the relation's field types. |
1241 |
|
my %types = map { $_->{name} => $_->{type} } @{$relationData->{Fields}}; |
1242 |
|
# We need to check for text fields so we can append a length limitation for them. To do |
1243 |
|
# that, we need the relation's field list. |
1244 |
|
my $relFields = $relationData->{Fields}; |
1245 |
|
for (my $i = 0; $i <= $#rawFields; $i++) { |
1246 |
|
# Get the field type. |
1247 |
|
my $field = $rawFields[$i]; |
1248 |
|
my $type = $types{$field}; |
1249 |
|
# Ask if it requires using prefix notation for the index. |
1250 |
|
my $mod = $TypeTable{$type}->{indexMod}; |
1251 |
|
Trace("Field $field ($i) in $relationName has type $type and indexMod $mod.") if T(3); |
1252 |
|
if ($mod) { |
1253 |
|
# Append the prefix length to the field name, |
1254 |
|
$rawFields[$i] .= "($mod)"; |
1255 |
|
} |
1256 |
|
} |
1257 |
|
my @fieldList = _FixNames(@rawFields); |
1258 |
my $flds = join(', ', @fieldList); |
my $flds = join(', ', @fieldList); |
1259 |
# Get the index's uniqueness flag. |
# Get the index's uniqueness flag. |
1260 |
my $unique = (exists $indexData->{Unique} ? 'unique' : undef); |
my $unique = (exists $indexData->{Unique} ? 'unique' : undef); |
1269 |
} |
} |
1270 |
} |
} |
1271 |
|
|
1272 |
|
=head3 GetSecondaryFields |
1273 |
|
|
1274 |
|
my %fieldTuples = $erdb->GetSecondaryFields($entityName); |
1275 |
|
|
1276 |
|
This method will return a list of the name and type of each of the secondary |
1277 |
|
fields for a specified entity. Secondary fields are stored in two-column tables |
1278 |
|
in addition to the primary entity table. This enables the field to have no value |
1279 |
|
or to have multiple values. |
1280 |
|
|
1281 |
|
=over 4 |
1282 |
|
|
1283 |
|
=item entityName |
1284 |
|
|
1285 |
|
Name of the entity whose secondary fields are desired. |
1286 |
|
|
1287 |
|
=item RETURN |
1288 |
|
|
1289 |
|
Returns a hash mapping the field names to their field types. |
1290 |
|
|
1291 |
|
=back |
1292 |
|
|
1293 |
|
=cut |
1294 |
|
|
1295 |
|
sub GetSecondaryFields { |
1296 |
|
# Get the parameters. |
1297 |
|
my ($self, $entityName) = @_; |
1298 |
|
# Declare the return variable. |
1299 |
|
my %retVal = (); |
1300 |
|
# Look for the entity. |
1301 |
|
my $table = $self->GetFieldTable($entityName); |
1302 |
|
# Loop through the fields, pulling out the secondaries. |
1303 |
|
for my $field (sort keys %{$table}) { |
1304 |
|
if ($table->{$field}->{relation} ne $entityName) { |
1305 |
|
# Here we have a secondary field. |
1306 |
|
$retVal{$field} = $table->{$field}->{type}; |
1307 |
|
} |
1308 |
|
} |
1309 |
|
# Return the result. |
1310 |
|
return %retVal; |
1311 |
|
} |
1312 |
|
|
1313 |
|
=head3 GetFieldRelationName |
1314 |
|
|
1315 |
|
my $name = $erdb->GetFieldRelationName($objectName, $fieldName); |
1316 |
|
|
1317 |
|
Return the name of the relation containing a specified field. |
1318 |
|
|
1319 |
|
=over 4 |
1320 |
|
|
1321 |
|
=item objectName |
1322 |
|
|
1323 |
|
Name of the entity or relationship containing the field. |
1324 |
|
|
1325 |
|
=item fieldName |
1326 |
|
|
1327 |
|
Name of the relevant field in that entity or relationship. |
1328 |
|
|
1329 |
|
=item RETURN |
1330 |
|
|
1331 |
|
Returns the name of the database relation containing the field, or C<undef> if |
1332 |
|
the field does not exist. |
1333 |
|
|
1334 |
|
=back |
1335 |
|
|
1336 |
|
=cut |
1337 |
|
|
1338 |
|
sub GetFieldRelationName { |
1339 |
|
# Get the parameters. |
1340 |
|
my ($self, $objectName, $fieldName) = @_; |
1341 |
|
# Declare the return variable. |
1342 |
|
my $retVal; |
1343 |
|
# Get the object field table. |
1344 |
|
my $table = $self->GetFieldTable($objectName); |
1345 |
|
# Only proceed if the field exists. |
1346 |
|
if (exists $table->{$fieldName}) { |
1347 |
|
# Determine the name of the relation that contains this field. |
1348 |
|
$retVal = $table->{$fieldName}->{relation}; |
1349 |
|
} |
1350 |
|
# Return the result. |
1351 |
|
return $retVal; |
1352 |
|
} |
1353 |
|
|
1354 |
|
=head3 DeleteValue |
1355 |
|
|
1356 |
|
my $numDeleted = $erdb->DeleteValue($entityName, $id, $fieldName, $fieldValue); |
1357 |
|
|
1358 |
|
Delete secondary field values from the database. This method can be used to delete all |
1359 |
|
values of a specified field for a particular entity instance, or only a single value. |
1360 |
|
|
1361 |
|
Secondary fields are stored in two-column relations separate from an entity's primary |
1362 |
|
table, and as a result a secondary field can legitimately have no value or multiple |
1363 |
|
values. Therefore, it makes sense to talk about deleting secondary fields where it |
1364 |
|
would not make sense for primary fields. |
1365 |
|
|
1366 |
|
=over 4 |
1367 |
|
|
1368 |
|
=item entityName |
1369 |
|
|
1370 |
|
Name of the entity from which the fields are to be deleted. |
1371 |
|
|
1372 |
|
=item id |
1373 |
|
|
1374 |
|
ID of the entity instance to be processed. If the instance is not found, this |
1375 |
|
method will have no effect. If C<undef> is specified, all values for all of |
1376 |
|
the entity instances will be deleted. |
1377 |
|
|
1378 |
|
=item fieldName |
1379 |
|
|
1380 |
|
Name of the field whose values are to be deleted. |
1381 |
|
|
1382 |
|
=item fieldValue (optional) |
1383 |
|
|
1384 |
|
Value to be deleted. If not specified, then all values of the specified field |
1385 |
|
will be deleted for the entity instance. If specified, then only the values which |
1386 |
|
match this parameter will be deleted. |
1387 |
|
|
1388 |
|
=item RETURN |
1389 |
|
|
1390 |
|
Returns the number of rows deleted. |
1391 |
|
|
1392 |
|
=back |
1393 |
|
|
1394 |
|
=cut |
1395 |
|
|
1396 |
|
sub DeleteValue { |
1397 |
|
# Get the parameters. |
1398 |
|
my ($self, $entityName, $id, $fieldName, $fieldValue) = @_; |
1399 |
|
# Declare the return value. |
1400 |
|
my $retVal = 0; |
1401 |
|
# We need to set up an SQL command to do the deletion. First, we |
1402 |
|
# find the name of the field's relation. |
1403 |
|
my $table = $self->GetFieldTable($entityName); |
1404 |
|
my $field = $table->{$fieldName}; |
1405 |
|
my $relation = $field->{relation}; |
1406 |
|
# Make sure this is a secondary field. |
1407 |
|
if ($relation eq $entityName) { |
1408 |
|
Confess("Cannot delete values of $fieldName for $entityName."); |
1409 |
|
} else { |
1410 |
|
# Set up the SQL command to delete all values. |
1411 |
|
my $sql = "DELETE FROM $relation"; |
1412 |
|
# Build the filter. |
1413 |
|
my @filters = (); |
1414 |
|
my @parms = (); |
1415 |
|
# Check for a filter by ID. |
1416 |
|
if (defined $id) { |
1417 |
|
push @filters, "id = ?"; |
1418 |
|
push @parms, $id; |
1419 |
|
} |
1420 |
|
# Check for a filter by value. |
1421 |
|
if (defined $fieldValue) { |
1422 |
|
push @filters, "$fieldName = ?"; |
1423 |
|
push @parms, $fieldValue; |
1424 |
|
} |
1425 |
|
# Append the filters to the command. |
1426 |
|
if (@filters) { |
1427 |
|
$sql .= " WHERE " . join(" AND ", @filters); |
1428 |
|
} |
1429 |
|
# Execute the command. |
1430 |
|
my $dbh = $self->{_dbh}; |
1431 |
|
$retVal = $dbh->SQL($sql, 0, @parms); |
1432 |
|
} |
1433 |
|
# Return the result. |
1434 |
|
return $retVal; |
1435 |
|
} |
1436 |
|
|
1437 |
=head3 LoadTables |
=head3 LoadTables |
1438 |
|
|
1439 |
C<< my $stats = $erdb->LoadTables($directoryName, $rebuild); >> |
my $stats = $erdb->LoadTables($directoryName, $rebuild); |
1440 |
|
|
1441 |
This method will load the database tables from a directory. The tables must already have been created |
This method will load the database tables from a directory. The tables must already have been created |
1442 |
in the database. (This can be done by calling L</CreateTables>.) The caller passes in a directory name; |
in the database. (This can be done by calling L</CreateTables>.) The caller passes in a directory name; |
1496 |
|
|
1497 |
=head3 GetTableNames |
=head3 GetTableNames |
1498 |
|
|
1499 |
C<< my @names = $erdb->GetTableNames; >> |
my @names = $erdb->GetTableNames; |
1500 |
|
|
1501 |
Return a list of the relations required to implement this database. |
Return a list of the relations required to implement this database. |
1502 |
|
|
1513 |
|
|
1514 |
=head3 GetEntityTypes |
=head3 GetEntityTypes |
1515 |
|
|
1516 |
C<< my @names = $erdb->GetEntityTypes; >> |
my @names = $erdb->GetEntityTypes; |
1517 |
|
|
1518 |
Return a list of the entity type names. |
Return a list of the entity type names. |
1519 |
|
|
1528 |
return sort keys %{$entityList}; |
return sort keys %{$entityList}; |
1529 |
} |
} |
1530 |
|
|
1531 |
|
=head3 GetConnectingRelationships |
1532 |
|
|
1533 |
|
my @list = $erdb->GetConnectingRelationships($entityName); |
1534 |
|
|
1535 |
|
Return a list of the relationships connected to the specified entity. |
1536 |
|
|
1537 |
|
=over 4 |
1538 |
|
|
1539 |
|
=item entityName |
1540 |
|
|
1541 |
|
Entity whose connected relationships are desired. |
1542 |
|
|
1543 |
|
=item RETURN |
1544 |
|
|
1545 |
|
Returns a list of the relationships that originate from the entity. |
1546 |
|
If the entity is on the from end, it will return the relationship |
1547 |
|
name. If the entity is on the to end it will return the converse of |
1548 |
|
the relationship name. |
1549 |
|
|
1550 |
|
=back |
1551 |
|
|
1552 |
|
=cut |
1553 |
|
|
1554 |
|
sub GetConnectingRelationships { |
1555 |
|
# Get the parameters. |
1556 |
|
my ($self, $entityName) = @_; |
1557 |
|
# Declare the return variable. |
1558 |
|
my @retVal; |
1559 |
|
# Get the relationship list. |
1560 |
|
my $relationships = $self->{_metaData}->{Relationships}; |
1561 |
|
# Find the entity. |
1562 |
|
my $entity = $self->{_metaData}->{Entities}->{$entityName}; |
1563 |
|
# Only proceed if the entity exists. |
1564 |
|
if (! defined $entity) { |
1565 |
|
Trace("Entity $entityName not found.") if T(3); |
1566 |
|
} else { |
1567 |
|
# Loop through the relationships. |
1568 |
|
my @rels = keys %$relationships; |
1569 |
|
Trace(scalar(@rels) . " relationships found in connection search.") if T(3); |
1570 |
|
for my $relationshipName (@rels) { |
1571 |
|
my $relationship = $relationships->{$relationshipName}; |
1572 |
|
if ($relationship->{from} eq $entityName) { |
1573 |
|
# Here we have a forward relationship. |
1574 |
|
push @retVal, $relationshipName; |
1575 |
|
} elsif ($relationship->{to} eq $entityName) { |
1576 |
|
# Here we have a backward relationship. In this case, the |
1577 |
|
# converse relationship name is preferred if it exists. |
1578 |
|
my $converse = $relationship->{converse} || $relationshipName; |
1579 |
|
push @retVal, $converse; |
1580 |
|
} |
1581 |
|
} |
1582 |
|
} |
1583 |
|
# Return the result. |
1584 |
|
return @retVal; |
1585 |
|
} |
1586 |
|
|
1587 |
|
|
1588 |
|
|
1589 |
|
|
1590 |
|
=head3 GetDataTypes |
1591 |
|
|
1592 |
|
my %types = ERDB::GetDataTypes(); |
1593 |
|
|
1594 |
|
Return a table of ERDB data types. The table returned is a hash of hashes. |
1595 |
|
The keys of the big hash are the datatypes. Each smaller hash has several |
1596 |
|
values used to manage the data. The most interesting is the SQL type (key |
1597 |
|
C<sqlType>) and the descriptive node (key C<notes>). |
1598 |
|
|
1599 |
|
Note that changing the values in the smaller hashes will seriously break |
1600 |
|
things, so this data should be treated as read-only. |
1601 |
|
|
1602 |
|
=cut |
1603 |
|
|
1604 |
|
sub GetDataTypes { |
1605 |
|
return %TypeTable; |
1606 |
|
} |
1607 |
|
|
1608 |
|
|
1609 |
=head3 IsEntity |
=head3 IsEntity |
1610 |
|
|
1611 |
C<< my $flag = $erdb->IsEntity($entityName); >> |
my $flag = $erdb->IsEntity($entityName); |
1612 |
|
|
1613 |
Return TRUE if the parameter is an entity name, else FALSE. |
Return TRUE if the parameter is an entity name, else FALSE. |
1614 |
|
|
1635 |
|
|
1636 |
=head3 Get |
=head3 Get |
1637 |
|
|
1638 |
C<< my $query = $erdb->Get(\@objectNames, $filterClause, \@params); >> |
my $query = $erdb->Get(\@objectNames, $filterClause, \@params); |
1639 |
|
|
1640 |
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. |
1641 |
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 |
1643 |
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 |
1644 |
$genus. |
$genus. |
1645 |
|
|
1646 |
C<< $query = $erdb->Get(['Genome'], "Genome(genus) = ?", [$genus]); >> |
$query = $erdb->Get(['Genome'], "Genome(genus) = ?", [$genus]); |
1647 |
|
|
1648 |
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 |
1649 |
parameter representing the parameter value. It would also be possible to code |
parameter representing the parameter value. It would also be possible to code |
1650 |
|
|
1651 |
C<< $query = $erdb->Get(['Genome'], "Genome(genus) = \'$genus\'"); >> |
$query = $erdb->Get(['Genome'], "Genome(genus) = \'$genus\'"); |
1652 |
|
|
1653 |
however, this version of the call would generate a syntax error if there were any quote |
however, this version of the call would generate a syntax error if there were any quote |
1654 |
characters inside the variable C<$genus>. |
characters inside the variable C<$genus>. |
1660 |
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 |
1661 |
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, |
1662 |
|
|
1663 |
C<< $query = $erdb->Get(['Genome', 'ComesFrom', 'Source'], "Genome(genus) = ?", [$genus]); >> |
$query = $erdb->Get(['Genome', 'ComesFrom', 'Source'], "Genome(genus) = ?", [$genus]); |
1664 |
|
|
1665 |
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 |
1666 |
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. |
1696 |
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
1697 |
particular genus and sorts them by species name. |
particular genus and sorts them by species name. |
1698 |
|
|
1699 |
C<< "Genome(genus) = ? ORDER BY Genome(species)" >> |
"Genome(genus) = ? ORDER BY Genome(species)" |
1700 |
|
|
1701 |
Note that the case is important. Only an uppercase "ORDER BY" with a single space will |
Note that the case is important. Only an uppercase "ORDER BY" with a single space will |
1702 |
be processed. The idea is to make it less likely to find the verb by accident. |
be processed. The idea is to make it less likely to find the verb by accident. |
1709 |
be the last thing in the filter clause, and it contains only the word "LIMIT" followed by |
be the last thing in the filter clause, and it contains only the word "LIMIT" followed by |
1710 |
a positive number. So, for example |
a positive number. So, for example |
1711 |
|
|
1712 |
C<< "Genome(genus) = ? ORDER BY Genome(species) LIMIT 10" >> |
"Genome(genus) = ? ORDER BY Genome(species) LIMIT 10" |
1713 |
|
|
1714 |
will only return the first ten genomes for the specified genus. The ORDER BY clause is not |
will only return the first ten genomes for the specified genus. The ORDER BY clause is not |
1715 |
required. For example, to just get the first 10 genomes in the B<Genome> table, you could |
required. For example, to just get the first 10 genomes in the B<Genome> table, you could |
1716 |
use |
use |
1717 |
|
|
1718 |
C<< "LIMIT 10" >> |
"LIMIT 10" |
1719 |
|
|
1720 |
=item params |
=item params |
1721 |
|
|
1736 |
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = |
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = |
1737 |
$self->_SetupSQL($objectNames, $filterClause); |
$self->_SetupSQL($objectNames, $filterClause); |
1738 |
# Create the query. |
# Create the query. |
1739 |
my $command = "SELECT DISTINCT " . join(".*, ", @{$mappedNameListRef}) . |
my $command = "SELECT " . join(".*, ", @{$mappedNameListRef}) . |
1740 |
".* $suffix"; |
".* $suffix"; |
1741 |
my $sth = $self->_GetStatementHandle($command, $params); |
my $sth = $self->_GetStatementHandle($command, $params); |
1742 |
# Now we create the relation map, which enables DBQuery to determine the order, name |
# Now we create the relation map, which enables DBQuery to determine the order, name |
1750 |
return $retVal; |
return $retVal; |
1751 |
} |
} |
1752 |
|
|
1753 |
|
|
1754 |
|
|
1755 |
=head3 Search |
=head3 Search |
1756 |
|
|
1757 |
C<< my $query = $erdb->Search($searchExpression, $idx, \@objectNames, $filterClause, \@params); >> |
my $query = $erdb->Search($searchExpression, $idx, \@objectNames, $filterClause, \@params); |
1758 |
|
|
1759 |
Perform a full text search with filtering. The search will be against a specified object |
Perform a full text search with filtering. The search will be against a specified object |
1760 |
in the object name list. That object will get an extra field containing the search |
in the object name list. That object will get an extra field containing the search |
1765 |
|
|
1766 |
=item searchExpression |
=item searchExpression |
1767 |
|
|
1768 |
Boolean search expression for the text fields of the target object. |
Boolean search expression for the text fields of the target object. The default mode for |
1769 |
|
a Boolean search expression is OR, but we want the default to be AND, so we will |
1770 |
|
add a C<+> operator to each word with no other operator before it. |
1771 |
|
|
1772 |
=item idx |
=item idx |
1773 |
|
|
1804 |
my ($self, $searchExpression, $idx, $objectNames, $filterClause, $params) = @_; |
my ($self, $searchExpression, $idx, $objectNames, $filterClause, $params) = @_; |
1805 |
# Declare the return variable. |
# Declare the return variable. |
1806 |
my $retVal; |
my $retVal; |
1807 |
# Create a safety copy of the parameter list. |
# Create a safety copy of the parameter list. Note we have to be careful to insure |
1808 |
my @myParams = @{$params}; |
# a parameter list exists before we copy it. |
1809 |
|
my @myParams = (); |
1810 |
|
if (defined $params) { |
1811 |
|
@myParams = @{$params}; |
1812 |
|
} |
1813 |
# Get the first object's structure so we have access to the searchable fields. |
# Get the first object's structure so we have access to the searchable fields. |
1814 |
my $object1Name = $objectNames->[$idx]; |
my $object1Name = $objectNames->[$idx]; |
1815 |
my $object1Structure = $self->_GetStructure($object1Name); |
my $object1Structure = $self->_GetStructure($object1Name); |
1821 |
my @fields = @{$object1Structure->{searchFields}}; |
my @fields = @{$object1Structure->{searchFields}}; |
1822 |
# Clean the search expression. |
# Clean the search expression. |
1823 |
my $actualKeywords = $self->CleanKeywords($searchExpression); |
my $actualKeywords = $self->CleanKeywords($searchExpression); |
1824 |
|
# Prefix a "+" to each uncontrolled word. This converts the default |
1825 |
|
# search mode from OR to AND. |
1826 |
|
$actualKeywords =~ s/(^|\s)(\w|")/$1\+$2/g; |
1827 |
|
Trace("Actual keywords for search are\n$actualKeywords") if T(3); |
1828 |
# We need two match expressions, one for the filter clause and one in the |
# We need two match expressions, one for the filter clause and one in the |
1829 |
# query itself. Both will use a parameter mark, so we need to push the |
# query itself. Both will use a parameter mark, so we need to push the |
1830 |
# search expression onto the front of the parameter list twice. |
# search expression onto the front of the parameter list twice. |
1837 |
$self->_SetupSQL($objectNames, $filterClause, $matchClause); |
$self->_SetupSQL($objectNames, $filterClause, $matchClause); |
1838 |
# Create the query. Note that the match clause is inserted at the front of |
# Create the query. Note that the match clause is inserted at the front of |
1839 |
# the select fields. |
# the select fields. |
1840 |
my $command = "SELECT DISTINCT $matchClause, " . join(".*, ", @{$mappedNameListRef}) . |
my $command = "SELECT $matchClause, " . join(".*, ", @{$mappedNameListRef}) . |
1841 |
".* $suffix"; |
".* $suffix"; |
1842 |
my $sth = $self->_GetStatementHandle($command, \@myParams); |
my $sth = $self->_GetStatementHandle($command, \@myParams); |
1843 |
# Now we create the relation map, which enables DBQuery to determine the order, name |
# Now we create the relation map, which enables DBQuery to determine the order, name |
1851 |
|
|
1852 |
=head3 GetFlat |
=head3 GetFlat |
1853 |
|
|
1854 |
C<< my @list = $erdb->GetFlat(\@objectNames, $filterClause, \@parameterList, $field); >> |
my @list = $erdb->GetFlat(\@objectNames, $filterClause, \@parameterList, $field); |
1855 |
|
|
1856 |
This is a variation of L</GetAll> that asks for only a single field per record and |
This is a variation of L</GetAll> that asks for only a single field per record and |
1857 |
returns a single flattened list. |
returns a single flattened list. |
1902 |
return @retVal; |
return @retVal; |
1903 |
} |
} |
1904 |
|
|
1905 |
=head3 Delete |
=head3 SpecialFields |
1906 |
|
|
1907 |
C<< my $stats = $erdb->Delete($entityName, $objectID); >> |
my %specials = $erdb->SpecialFields($entityName); |
1908 |
|
|
1909 |
Delete an entity instance from the database. The instance is deleted along with all entity and |
Return a hash mapping special fields in the specified entity to the value of their |
1910 |
relationship instances dependent on it. The idea of dependence here is recursive. An object is |
C<special> attribute. This enables the subclass to get access to the special field |
1911 |
always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many |
attributes without needed to plumb the internal ERDB data structures. |
|
relationship connected to a dependent entity or the "to" entity connected to a 1-to-many |
|
|
dependent relationship. |
|
1912 |
|
|
1913 |
=over 4 |
=over 4 |
1914 |
|
|
1915 |
=item entityName |
=item entityName |
1916 |
|
|
1917 |
Name of the entity type for the instance being deleted. |
Name of the entity whose special fields are desired. |
1918 |
|
|
1919 |
=item objectID |
=item RETURN |
1920 |
|
|
1921 |
ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>), |
Returns a hash. The keys of the hash are the special field names, and the values |
1922 |
|
are the values from each special field's C<special> attribute. |
1923 |
|
|
1924 |
|
=back |
1925 |
|
|
1926 |
|
=cut |
1927 |
|
|
1928 |
|
sub SpecialFields { |
1929 |
|
# Get the parameters. |
1930 |
|
my ($self, $entityName) = @_; |
1931 |
|
# Declare the return variable. |
1932 |
|
my %retVal = (); |
1933 |
|
# Find the entity's data structure. |
1934 |
|
my $entityData = $self->{_metaData}->{Entities}->{$entityName}; |
1935 |
|
# Loop through its fields, adding each special field to the return hash. |
1936 |
|
my $fieldHash = $entityData->{Fields}; |
1937 |
|
for my $fieldName (keys %{$fieldHash}) { |
1938 |
|
my $fieldData = $fieldHash->{$fieldName}; |
1939 |
|
if (exists $fieldData->{special}) { |
1940 |
|
$retVal{$fieldName} = $fieldData->{special}; |
1941 |
|
} |
1942 |
|
} |
1943 |
|
# Return the result. |
1944 |
|
return %retVal; |
1945 |
|
} |
1946 |
|
|
1947 |
|
=head3 Delete |
1948 |
|
|
1949 |
|
my $stats = $erdb->Delete($entityName, $objectID, %options); |
1950 |
|
|
1951 |
|
Delete an entity instance from the database. The instance is deleted along with all entity and |
1952 |
|
relationship instances dependent on it. The definition of I<dependence> is recursive. |
1953 |
|
|
1954 |
|
An object is always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many |
1955 |
|
relationship connected to a dependent entity or if it is the "to" entity connected to a 1-to-many |
1956 |
|
dependent relationship. |
1957 |
|
|
1958 |
|
=over 4 |
1959 |
|
|
1960 |
|
=item entityName |
1961 |
|
|
1962 |
|
Name of the entity type for the instance being deleted. |
1963 |
|
|
1964 |
|
=item objectID |
1965 |
|
|
1966 |
|
ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>), |
1967 |
then it is presumed to by a LIKE pattern. |
then it is presumed to by a LIKE pattern. |
1968 |
|
|
1969 |
=item testFlag |
=item options |
1970 |
|
|
1971 |
If TRUE, the delete statements will be traced without being executed. |
A hash detailing the options for this delete operation. |
1972 |
|
|
1973 |
=item RETURN |
=item RETURN |
1974 |
|
|
1977 |
|
|
1978 |
=back |
=back |
1979 |
|
|
1980 |
|
The permissible options for this method are as follows. |
1981 |
|
|
1982 |
|
=over 4 |
1983 |
|
|
1984 |
|
=item testMode |
1985 |
|
|
1986 |
|
If TRUE, then the delete statements will be traced, but no changes will be made to the database. |
1987 |
|
|
1988 |
|
=item keepRoot |
1989 |
|
|
1990 |
|
If TRUE, then the entity instances will not be deleted, only the dependent records. |
1991 |
|
|
1992 |
|
=back |
1993 |
|
|
1994 |
=cut |
=cut |
1995 |
#: Return Type $%; |
#: Return Type $%; |
1996 |
sub Delete { |
sub Delete { |
1997 |
# Get the parameters. |
# Get the parameters. |
1998 |
my ($self, $entityName, $objectID, $testFlag) = @_; |
my ($self, $entityName, $objectID, %options) = @_; |
1999 |
# Declare the return variable. |
# Declare the return variable. |
2000 |
my $retVal = Stats->new(); |
my $retVal = Stats->new(); |
2001 |
# Get the DBKernel object. |
# Get the DBKernel object. |
2012 |
# FROM-relationships and entities. |
# FROM-relationships and entities. |
2013 |
my @fromPathList = (); |
my @fromPathList = (); |
2014 |
my @toPathList = (); |
my @toPathList = (); |
2015 |
# 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 |
2016 |
# 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 |
2017 |
# 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 |
2018 |
# TODO list is always an entity. |
# to-do list is always an entity. |
2019 |
my @todoList = ([$entityName]); |
my @todoList = ([$entityName]); |
2020 |
while (@todoList) { |
while (@todoList) { |
2021 |
# Get the current path. |
# Get the current path. |
2023 |
# Copy it into a list. |
# Copy it into a list. |
2024 |
my @stackedPath = @{$current}; |
my @stackedPath = @{$current}; |
2025 |
# 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. |
2026 |
my $entityName = pop @stackedPath; |
my $myEntityName = pop @stackedPath; |
2027 |
# Add it to the alreadyFound list. |
# Add it to the alreadyFound list. |
2028 |
$alreadyFound{$entityName} = 1; |
$alreadyFound{$myEntityName} = 1; |
2029 |
|
# Figure out if we need to delete this entity. |
2030 |
|
if ($myEntityName ne $entityName || ! $options{keepRoot}) { |
2031 |
# Get the entity data. |
# Get the entity data. |
2032 |
my $entityData = $self->_GetStructure($entityName); |
my $entityData = $self->_GetStructure($myEntityName); |
2033 |
# 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. |
|
2034 |
my $relations = $entityData->{Relations}; |
my $relations = $entityData->{Relations}; |
2035 |
for my $relation (keys %{$relations}) { |
for my $relation (keys %{$relations}) { |
2036 |
my @augmentedList = (@stackedPath, $relation); |
my @augmentedList = (@stackedPath, $relation); |
2037 |
push @fromPathList, \@augmentedList; |
push @fromPathList, \@augmentedList; |
2038 |
} |
} |
2039 |
|
} |
2040 |
# Now we need to look for relationships connected to this entity. |
# Now we need to look for relationships connected to this entity. |
2041 |
my $relationshipList = $self->{_metaData}->{Relationships}; |
my $relationshipList = $self->{_metaData}->{Relationships}; |
2042 |
for my $relationshipName (keys %{$relationshipList}) { |
for my $relationshipName (keys %{$relationshipList}) { |
2043 |
my $relationship = $relationshipList->{$relationshipName}; |
my $relationship = $relationshipList->{$relationshipName}; |
2044 |
# Check the FROM field. We're only interested if it's us. |
# Check the FROM field. We're only interested if it's us. |
2045 |
if ($relationship->{from} eq $entityName) { |
if ($relationship->{from} eq $myEntityName) { |
2046 |
# Add the path to this relationship. |
# Add the path to this relationship. |
2047 |
my @augmentedList = (@stackedPath, $entityName, $relationshipName); |
my @augmentedList = (@stackedPath, $myEntityName, $relationshipName); |
2048 |
push @fromPathList, \@augmentedList; |
push @fromPathList, \@augmentedList; |
2049 |
# 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 |
2050 |
# and the target hasn't been seen yet, we want to |
# and the target hasn't been seen yet, we want to |
2063 |
} |
} |
2064 |
# Now check the TO field. In this case only the relationship needs |
# Now check the TO field. In this case only the relationship needs |
2065 |
# deletion. |
# deletion. |
2066 |
if ($relationship->{to} eq $entityName) { |
if ($relationship->{to} eq $myEntityName) { |
2067 |
my @augmentedList = (@stackedPath, $entityName, $relationshipName); |
my @augmentedList = (@stackedPath, $myEntityName, $relationshipName); |
2068 |
push @toPathList, \@augmentedList; |
push @toPathList, \@augmentedList; |
2069 |
} |
} |
2070 |
} |
} |
2071 |
} |
} |
2072 |
# Create the first qualifier for the WHERE clause. This selects the |
# Create the first qualifier for the WHERE clause. This selects the |
2073 |
# 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 |
2074 |
# 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 |
2075 |
# to the table containing the dependent records to delete. |
# to the table containing the dependent records to delete. |
2076 |
my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?"); |
my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?"); |
2077 |
# 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 |
2110 |
} |
} |
2111 |
} |
} |
2112 |
# Now we have our desired DELETE statement. |
# Now we have our desired DELETE statement. |
2113 |
if ($testFlag) { |
if ($options{testMode}) { |
2114 |
# Here the user wants to trace without executing. |
# Here the user wants to trace without executing. |
2115 |
Trace($stmt) if T(0); |
Trace($stmt) if T(0); |
2116 |
} else { |
} else { |
2117 |
# 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 |
2118 |
# if an error occurs, so we just go ahead and do it. |
# if an error occurs, so we just go ahead and do it. |
2119 |
Trace("Executing delete from $target using '$objectID'.") if T(3); |
Trace("Executing delete from $target using '$objectID'.") if T(3); |
2120 |
my $rv = $db->SQL($stmt, 0, $objectID); |
my $rv = $db->SQL($stmt, 0, $objectID); |
2129 |
return $retVal; |
return $retVal; |
2130 |
} |
} |
2131 |
|
|
2132 |
|
=head3 Disconnect |
2133 |
|
|
2134 |
|
$erdb->Disconnect($relationshipName, $originEntityName, $originEntityID); |
2135 |
|
|
2136 |
|
Disconnect an entity instance from all the objects to which it is related. This |
2137 |
|
will delete each relationship instance that connects to the specified entity. |
2138 |
|
|
2139 |
|
=over 4 |
2140 |
|
|
2141 |
|
=item relationshipName |
2142 |
|
|
2143 |
|
Name of the relationship whose instances are to be deleted. |
2144 |
|
|
2145 |
|
=item originEntityName |
2146 |
|
|
2147 |
|
Name of the entity that is to be disconnected. |
2148 |
|
|
2149 |
|
=item originEntityID |
2150 |
|
|
2151 |
|
ID of the entity that is to be disconnected. |
2152 |
|
|
2153 |
|
=back |
2154 |
|
|
2155 |
|
=cut |
2156 |
|
|
2157 |
|
sub Disconnect { |
2158 |
|
# Get the parameters. |
2159 |
|
my ($self, $relationshipName, $originEntityName, $originEntityID) = @_; |
2160 |
|
# Get the relationship descriptor. |
2161 |
|
my $structure = $self->_GetStructure($relationshipName); |
2162 |
|
# Insure we have a relationship. |
2163 |
|
if (! exists $structure->{from}) { |
2164 |
|
Confess("$relationshipName is not a relationship in the database."); |
2165 |
|
} else { |
2166 |
|
# Get the database handle. |
2167 |
|
my $dbh = $self->{_dbh}; |
2168 |
|
# We'll set this value to 1 if we find our entity. |
2169 |
|
my $found = 0; |
2170 |
|
# Loop through the ends of the relationship. |
2171 |
|
for my $dir ('from', 'to') { |
2172 |
|
if ($structure->{$dir} eq $originEntityName) { |
2173 |
|
$found = 1; |
2174 |
|
# Here we want to delete all relationship instances on this side of the |
2175 |
|
# entity instance. |
2176 |
|
Trace("Disconnecting in $dir direction with ID \"$originEntityID\"."); |
2177 |
|
# We do this delete in batches to keep it from dragging down the |
2178 |
|
# server. |
2179 |
|
my $limitClause = ($FIG_Config::delete_limit ? "LIMIT $FIG_Config::delete_limit" : ""); |
2180 |
|
my $done = 0; |
2181 |
|
while (! $done) { |
2182 |
|
# Do the delete. |
2183 |
|
my $rows = $dbh->SQL("DELETE FROM $relationshipName WHERE ${dir}_link = ? $limitClause", 0, $originEntityID); |
2184 |
|
# See if we're done. We're done if no rows were found or the delete is unlimited. |
2185 |
|
$done = ($rows == 0 || ! $limitClause); |
2186 |
|
} |
2187 |
|
} |
2188 |
|
} |
2189 |
|
# Insure we found the entity on at least one end. |
2190 |
|
if (! $found) { |
2191 |
|
Confess("Entity \"$originEntityName\" does not use $relationshipName."); |
2192 |
|
} |
2193 |
|
} |
2194 |
|
} |
2195 |
|
|
2196 |
|
=head3 DeleteRow |
2197 |
|
|
2198 |
|
$erdb->DeleteRow($relationshipName, $fromLink, $toLink, \%values); |
2199 |
|
|
2200 |
|
Delete a row from a relationship. In most cases, only the from-link and to-link are |
2201 |
|
needed; however, for relationships with intersection data values can be specified |
2202 |
|
for the other fields using a hash. |
2203 |
|
|
2204 |
|
=over 4 |
2205 |
|
|
2206 |
|
=item relationshipName |
2207 |
|
|
2208 |
|
Name of the relationship from which the row is to be deleted. |
2209 |
|
|
2210 |
|
=item fromLink |
2211 |
|
|
2212 |
|
ID of the entity instance in the From direction. |
2213 |
|
|
2214 |
|
=item toLink |
2215 |
|
|
2216 |
|
ID of the entity instance in the To direction. |
2217 |
|
|
2218 |
|
=item values |
2219 |
|
|
2220 |
|
Reference to a hash of other values to be used for filtering the delete. |
2221 |
|
|
2222 |
|
=back |
2223 |
|
|
2224 |
|
=cut |
2225 |
|
|
2226 |
|
sub DeleteRow { |
2227 |
|
# Get the parameters. |
2228 |
|
my ($self, $relationshipName, $fromLink, $toLink, $values) = @_; |
2229 |
|
# Create a hash of all the filter information. |
2230 |
|
my %filter = ('from-link' => $fromLink, 'to-link' => $toLink); |
2231 |
|
if (defined $values) { |
2232 |
|
for my $key (keys %{$values}) { |
2233 |
|
$filter{$key} = $values->{$key}; |
2234 |
|
} |
2235 |
|
} |
2236 |
|
# Build an SQL statement out of the hash. |
2237 |
|
my @filters = (); |
2238 |
|
my @parms = (); |
2239 |
|
for my $key (keys %filter) { |
2240 |
|
push @filters, _FixName($key) . " = ?"; |
2241 |
|
push @parms, $filter{$key}; |
2242 |
|
} |
2243 |
|
Trace("Parms for delete row are " . join(", ", map { "\"$_\"" } @parms) . ".") if T(SQL => 4); |
2244 |
|
my $command = "DELETE FROM $relationshipName WHERE " . |
2245 |
|
join(" AND ", @filters); |
2246 |
|
# Execute it. |
2247 |
|
my $dbh = $self->{_dbh}; |
2248 |
|
$dbh->SQL($command, undef, @parms); |
2249 |
|
} |
2250 |
|
|
2251 |
|
=head3 DeleteLike |
2252 |
|
|
2253 |
|
my $deleteCount = $erdb->DeleteLike($relName, $filter, \@parms); |
2254 |
|
|
2255 |
|
Delete all the relationship rows that satisfy a particular filter condition. Unlike a normal |
2256 |
|
filter, only fields from the relationship itself can be used. |
2257 |
|
|
2258 |
|
=over 4 |
2259 |
|
|
2260 |
|
=item relName |
2261 |
|
|
2262 |
|
Name of the relationship whose records are to be deleted. |
2263 |
|
|
2264 |
|
=item filter |
2265 |
|
|
2266 |
|
A filter clause (L</Get>-style) for the delete query. |
2267 |
|
|
2268 |
|
=item parms |
2269 |
|
|
2270 |
|
Reference to a list of parameters for the filter clause. |
2271 |
|
|
2272 |
|
=item RETURN |
2273 |
|
|
2274 |
|
Returns a count of the number of rows deleted. |
2275 |
|
|
2276 |
|
=back |
2277 |
|
|
2278 |
|
=cut |
2279 |
|
|
2280 |
|
sub DeleteLike { |
2281 |
|
# Get the parameters. |
2282 |
|
my ($self, $objectName, $filter, $parms) = @_; |
2283 |
|
# Declare the return variable. |
2284 |
|
my $retVal; |
2285 |
|
# Insure the parms argument is an array reference if the caller left it off. |
2286 |
|
if (! defined($parms)) { |
2287 |
|
$parms = []; |
2288 |
|
} |
2289 |
|
# Insure we have a relationship. The main reason for this is if we delete an entity |
2290 |
|
# instance we have to yank out a bunch of other stuff with it. |
2291 |
|
if ($self->IsEntity($objectName)) { |
2292 |
|
Confess("Cannot use DeleteLike on $objectName, because it is not a relationship."); |
2293 |
|
} else { |
2294 |
|
# Create the SQL command suffix to get the desierd records. |
2295 |
|
my ($suffix) = $self->_SetupSQL([$objectName], $filter); |
2296 |
|
# Convert it to a DELETE command. |
2297 |
|
my $command = "DELETE $suffix"; |
2298 |
|
# Execute the command. |
2299 |
|
my $dbh = $self->{_dbh}; |
2300 |
|
my $result = $dbh->SQL($command, 0, @{$parms}); |
2301 |
|
# Check the results. Note we convert the "0D0" result to a real zero. |
2302 |
|
# A failure causes an abnormal termination, so the caller isn't going to |
2303 |
|
# worry about it. |
2304 |
|
if (! defined $result) { |
2305 |
|
Confess("Error deleting from $objectName: " . $dbh->errstr()); |
2306 |
|
} elsif ($result == 0) { |
2307 |
|
$retVal = 0; |
2308 |
|
} else { |
2309 |
|
$retVal = $result; |
2310 |
|
} |
2311 |
|
} |
2312 |
|
# Return the result count. |
2313 |
|
return $retVal; |
2314 |
|
} |
2315 |
|
|
2316 |
=head3 SortNeeded |
=head3 SortNeeded |
2317 |
|
|
2318 |
C<< my $parms = $erdb->SortNeeded($relationName); >> |
my $parms = $erdb->SortNeeded($relationName); |
2319 |
|
|
2320 |
Return the pipe command for the sort that should be applied to the specified |
Return the pipe command for the sort that should be applied to the specified |
2321 |
relation when creating the load file. |
relation when creating the load file. |
2363 |
} elsif (exists $relationshipTable->{$relationName}) { |
} elsif (exists $relationshipTable->{$relationName}) { |
2364 |
# Here we have a relationship. We sort using the FROM index. |
# Here we have a relationship. We sort using the FROM index. |
2365 |
my $relationshipData = $relationshipTable->{$relationName}; |
my $relationshipData = $relationshipTable->{$relationName}; |
2366 |
my $index = $relationData->{Indexes}->{"idx${relationName}From"}; |
my $index = $relationData->{Indexes}->{idxFrom}; |
2367 |
push @keyNames, @{$index->{IndexFields}}; |
push @keyNames, @{$index->{IndexFields}}; |
2368 |
} else { |
} else { |
2369 |
# Here we have a secondary entity relation, so we have a sort on the ID field. |
# Here we have a secondary entity relation, so we have a sort on the ID field. |
2371 |
} |
} |
2372 |
# Now we parse the key names into sort parameters. First, we prime the return |
# Now we parse the key names into sort parameters. First, we prime the return |
2373 |
# string. |
# string. |
2374 |
my $retVal = "sort -t\"\t\" "; |
my $retVal = "sort -S 1G -T\"$FIG_Config::temp\" -t\"\t\" "; |
2375 |
# Get the relation's field list. |
# Get the relation's field list. |
2376 |
my @fields = @{$relationData->{Fields}}; |
my @fields = @{$relationData->{Fields}}; |
2377 |
# Loop through the keys. |
# Loop through the keys. |
2401 |
# will stop the inner loop. Note that the field number is |
# will stop the inner loop. Note that the field number is |
2402 |
# 1-based in the sort command, so we have to increment the |
# 1-based in the sort command, so we have to increment the |
2403 |
# index. |
# index. |
2404 |
$fieldSpec = ($i + 1) . $modifier; |
my $realI = $i + 1; |
2405 |
|
$fieldSpec = "$realI,$realI$modifier"; |
2406 |
} |
} |
2407 |
} |
} |
2408 |
# Add this field to the sort command. |
# Add this field to the sort command. |
2414 |
|
|
2415 |
=head3 GetList |
=head3 GetList |
2416 |
|
|
2417 |
C<< my @dbObjects = $erdb->GetList(\@objectNames, $filterClause, \@params); >> |
my @dbObjects = $erdb->GetList(\@objectNames, $filterClause, \@params); |
2418 |
|
|
2419 |
Return a list of object descriptors for the specified objects as determined by the |
Return a list of object descriptors for the specified objects as determined by the |
2420 |
specified filter clause. |
specified filter clause. |
2442 |
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
with an ORDER BY clause. For example, the following filter string gets all genomes for a |
2443 |
particular genus and sorts them by species name. |
particular genus and sorts them by species name. |
2444 |
|
|
2445 |
C<< "Genome(genus) = ? ORDER BY Genome(species)" >> |
"Genome(genus) = ? ORDER BY Genome(species)" |
2446 |
|
|
2447 |
The rules for field references in a sort order are the same as those for field references in the |
The rules for field references in a sort order are the same as those for field references in the |
2448 |
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 |
2454 |
|
|
2455 |
=item RETURN |
=item RETURN |
2456 |
|
|
2457 |
Returns a list of B<DBObject>s that satisfy the query conditions. |
Returns a list of B<ERDBObject>s that satisfy the query conditions. |
2458 |
|
|
2459 |
=back |
=back |
2460 |
|
|
2477 |
|
|
2478 |
=head3 GetCount |
=head3 GetCount |
2479 |
|
|
2480 |
C<< my $count = $erdb->GetCount(\@objectNames, $filter, \@params); >> |
my $count = $erdb->GetCount(\@objectNames, $filter, \@params); |
2481 |
|
|
2482 |
Return the number of rows found by a specified query. This method would |
Return the number of rows found by a specified query. This method would |
2483 |
normally be used to count the records in a single table. For example, in a |
normally be used to count the records in a single table. For example, in a |
2570 |
|
|
2571 |
=head3 ComputeObjectSentence |
=head3 ComputeObjectSentence |
2572 |
|
|
2573 |
C<< my $sentence = $erdb->ComputeObjectSentence($objectName); >> |
my $sentence = $erdb->ComputeObjectSentence($objectName); |
2574 |
|
|
2575 |
Check an object name, and if it is a relationship convert it to a relationship sentence. |
Check an object name, and if it is a relationship convert it to a relationship sentence. |
2576 |
|
|
2605 |
|
|
2606 |
=head3 DumpRelations |
=head3 DumpRelations |
2607 |
|
|
2608 |
C<< $erdb->DumpRelations($outputDirectory); >> |
$erdb->DumpRelations($outputDirectory); |
2609 |
|
|
2610 |
Write the contents of all the relations to tab-delimited files in the specified directory. |
Write the contents of all the relations to tab-delimited files in the specified directory. |
2611 |
Each file will have the same name as the relation dumped, with an extension of DTX. |
Each file will have the same name as the relation dumped, with an extension of DTX. |
2647 |
|
|
2648 |
=head3 InsertValue |
=head3 InsertValue |
2649 |
|
|
2650 |
C<< $erdb->InsertValue($entityID, $fieldName, $value); >> |
$erdb->InsertValue($entityID, $fieldName, $value); |
2651 |
|
|
2652 |
This method will insert a new value into the database. The value must be one |
This method will insert a new value into the database. The value must be one |
2653 |
associated with a secondary relation, since primary values cannot be inserted: |
associated with a secondary relation, since primary values cannot be inserted: |
2710 |
|
|
2711 |
=head3 InsertObject |
=head3 InsertObject |
2712 |
|
|
2713 |
C<< my $ok = $erdb->InsertObject($objectType, \%fieldHash); >> |
$erdb->InsertObject($objectType, \%fieldHash); |
2714 |
|
|
2715 |
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 |
2716 |
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. |
2719 |
example, the following line inserts an inactive PEG feature named C<fig|188.1.peg.1> with aliases |
example, the following line inserts an inactive PEG feature named C<fig|188.1.peg.1> with aliases |
2720 |
C<ZP_00210270.1> and C<gi|46206278>. |
C<ZP_00210270.1> and C<gi|46206278>. |
2721 |
|
|
2722 |
C<< $erdb->InsertObject('Feature', { id => 'fig|188.1.peg.1', active => 0, feature-type => 'peg', alias => ['ZP_00210270.1', 'gi|46206278']}); >> |
$erdb->InsertObject('Feature', { id => 'fig|188.1.peg.1', active => 0, feature-type => 'peg', alias => ['ZP_00210270.1', 'gi|46206278']}); |
2723 |
|
|
2724 |
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 |
2725 |
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>. |
2726 |
|
|
2727 |
C<< $erdb->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence => 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); >> |
$erdb->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence => 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); |
2728 |
|
|
2729 |
=over 4 |
=over 4 |
2730 |
|
|
2736 |
|
|
2737 |
Hash of field names to values. |
Hash of field names to values. |
2738 |
|
|
|
=item RETURN |
|
|
|
|
|
Returns 1 if successful, 0 if an error occurred. |
|
|
|
|
2739 |
=back |
=back |
2740 |
|
|
2741 |
=cut |
=cut |
2793 |
push @missing, $fieldName; |
push @missing, $fieldName; |
2794 |
} |
} |
2795 |
} |
} |
|
# If we are the primary relation, add the new-record flag. |
|
|
if ($relationName eq $newObjectType) { |
|
|
push @valueList, 1; |
|
|
push @fieldNameList, "new_record"; |
|
|
} |
|
2796 |
# Only proceed if there are no missing fields. |
# Only proceed if there are no missing fields. |
2797 |
if (@missing > 0) { |
if (@missing > 0) { |
2798 |
Trace("Relation $relationName for $newObjectType skipped due to missing fields: " . |
Trace("Relation $relationName for $newObjectType skipped due to missing fields: " . |
2829 |
$retVal = $sth->execute(@parameterList); |
$retVal = $sth->execute(@parameterList); |
2830 |
if (!$retVal) { |
if (!$retVal) { |
2831 |
my $errorString = $sth->errstr(); |
my $errorString = $sth->errstr(); |
2832 |
Trace("Insert error: $errorString.") if T(0); |
Confess("Error inserting into $relationName: $errorString"); |
2833 |
|
} else { |
2834 |
|
Trace("Insert successful using $parameterList[0].") if T(3); |
2835 |
} |
} |
2836 |
} |
} |
2837 |
} |
} |
2838 |
} |
} |
2839 |
# Return the success indicator. |
# Return a 1 for backward compatability. |
2840 |
return $retVal; |
return 1; |
2841 |
|
} |
2842 |
|
|
2843 |
|
=head3 UpdateEntity |
2844 |
|
|
2845 |
|
$erdb->UpdateEntity($entityName, $id, \%fields); |
2846 |
|
|
2847 |
|
Update the values of an entity. This is an unprotected update, so it should only be |
2848 |
|
done if the database resides on a database server. |
2849 |
|
|
2850 |
|
=over 4 |
2851 |
|
|
2852 |
|
=item entityName |
2853 |
|
|
2854 |
|
Name of the entity to update. (This is the entity type.) |
2855 |
|
|
2856 |
|
=item id |
2857 |
|
|
2858 |
|
ID of the entity to update. If no entity exists with this ID, an error will be thrown. |
2859 |
|
|
2860 |
|
=item fields |
2861 |
|
|
2862 |
|
Reference to a hash mapping field names to their new values. All of the fields named |
2863 |
|
must be in the entity's primary relation, and they cannot any of them be the ID field. |
2864 |
|
|
2865 |
|
=back |
2866 |
|
|
2867 |
|
=cut |
2868 |
|
|
2869 |
|
sub UpdateEntity { |
2870 |
|
# Get the parameters. |
2871 |
|
my ($self, $entityName, $id, $fields) = @_; |
2872 |
|
# Get a list of the field names being updated. |
2873 |
|
my @fieldList = keys %{$fields}; |
2874 |
|
# Verify that the fields exist. |
2875 |
|
my $checker = $self->GetFieldTable($entityName); |
2876 |
|
for my $field (@fieldList) { |
2877 |
|
if ($field eq 'id') { |
2878 |
|
Confess("Cannot update the ID field for entity $entityName."); |
2879 |
|
} elsif ($checker->{$field}->{relation} ne $entityName) { |
2880 |
|
Confess("Cannot find $field in primary relation of $entityName."); |
2881 |
|
} |
2882 |
|
} |
2883 |
|
# Build the SQL statement. |
2884 |
|
my @sets = (); |
2885 |
|
my @valueList = (); |
2886 |
|
for my $field (@fieldList) { |
2887 |
|
push @sets, _FixName($field) . " = ?"; |
2888 |
|
push @valueList, $fields->{$field}; |
2889 |
|
} |
2890 |
|
my $command = "UPDATE $entityName SET " . join(", ", @sets) . " WHERE id = ?"; |
2891 |
|
# Add the ID to the list of binding values. |
2892 |
|
push @valueList, $id; |
2893 |
|
# Call SQL to do the work. |
2894 |
|
my $rows = $self->{_dbh}->SQL($command, 0, @valueList); |
2895 |
|
# Check for errors. |
2896 |
|
if ($rows == 0) { |
2897 |
|
Confess("Entity $id of type $entityName not found."); |
2898 |
|
} |
2899 |
} |
} |
2900 |
|
|
2901 |
=head3 LoadTable |
=head3 LoadTable |
2902 |
|
|
2903 |
C<< my %results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >> |
my $results = $erdb->LoadTable($fileName, $relationName, %options); |
2904 |
|
|
2905 |
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 |
2906 |
first. |
first. |
2915 |
|
|
2916 |
Name of the relation to be loaded. This is the same as the table name. |
Name of the relation to be loaded. This is the same as the table name. |
2917 |
|
|
2918 |
=item truncateFlag |
=item options |
2919 |
|
|
2920 |
TRUE if the table should be dropped and re-created, else FALSE |
A hash of load options. |
2921 |
|
|
2922 |
=item RETURN |
=item RETURN |
2923 |
|
|
2925 |
|
|
2926 |
=back |
=back |
2927 |
|
|
2928 |
|
The permissible options are as follows. |
2929 |
|
|
2930 |
|
=over 4 |
2931 |
|
|
2932 |
|
=item truncate |
2933 |
|
|
2934 |
|
If TRUE, then the table will be erased before loading. |
2935 |
|
|
2936 |
|
=item mode |
2937 |
|
|
2938 |
|
Mode in which the load should operate, either C<low_priority> or C<concurrent>. |
2939 |
|
This option is only applicable to a MySQL database. |
2940 |
|
|
2941 |
|
=item partial |
2942 |
|
|
2943 |
|
If TRUE, then it is assumed that this is a partial load, and the table will not |
2944 |
|
be analyzed and compacted at the end. |
2945 |
|
|
2946 |
|
=back |
2947 |
|
|
2948 |
=cut |
=cut |
2949 |
sub LoadTable { |
sub LoadTable { |
2950 |
# Get the parameters. |
# Get the parameters. |
2951 |
my ($self, $fileName, $relationName, $truncateFlag) = @_; |
my ($self, $fileName, $relationName, %options) = @_; |
2952 |
# Create the statistical return object. |
# Create the statistical return object. |
2953 |
my $retVal = _GetLoadStats(); |
my $retVal = _GetLoadStats(); |
2954 |
# Trace the fact of the load. |
# Trace the fact of the load. |
2960 |
# Get the relation data. |
# Get the relation data. |
2961 |
my $relation = $self->_FindRelation($relationName); |
my $relation = $self->_FindRelation($relationName); |
2962 |
# Check the truncation flag. |
# Check the truncation flag. |
2963 |
if ($truncateFlag) { |
if ($options{truncate}) { |
2964 |
Trace("Creating table $relationName") if T(2); |
Trace("Creating table $relationName") if T(2); |
2965 |
# Compute the row count estimate. We take the size of the load file, |
# Compute the row count estimate. We take the size of the load file, |
2966 |
# divide it by the estimated row size, and then multiply by 1.5 to |
# divide it by the estimated row size, and then multiply by 2 to |
2967 |
# leave extra room. We postulate a minimum row count of 1000 to |
# leave extra room. We postulate a minimum row count of 1000 to |
2968 |
# prevent problems with incoming empty load files. |
# prevent problems with incoming empty load files. |
2969 |
my $rowSize = $self->EstimateRowSize($relationName); |
my $rowSize = $self->EstimateRowSize($relationName); |
2970 |
my $estimate = FIG::max($fileSize * 1.5 / $rowSize, 1000); |
my $estimate = $fileSize * 8 / $rowSize; |
2971 |
|
if ($estimate < 1000) { |
2972 |
|
$estimate = 1000; |
2973 |
|
} |
2974 |
# Re-create the table without its index. |
# Re-create the table without its index. |
2975 |
$self->CreateTable($relationName, 0, $estimate); |
$self->CreateTable($relationName, 0, $estimate); |
2976 |
# If this is a pre-index DBMS, create the index here. |
# If this is a pre-index DBMS, create the index here. |
2986 |
# Load the table. |
# Load the table. |
2987 |
my $rv; |
my $rv; |
2988 |
eval { |
eval { |
2989 |
$rv = $dbh->load_table(file => $fileName, tbl => $relationName); |
$rv = $dbh->load_table(file => $fileName, tbl => $relationName, style => $options{mode}); |
2990 |
}; |
}; |
2991 |
if (!defined $rv) { |
if (!defined $rv) { |
2992 |
$retVal->AddMessage($@) if ($@); |
$retVal->AddMessage($@) if ($@); |
2993 |
$retVal->AddMessage("Table load failed for $relationName using $fileName."); |
$retVal->AddMessage("Table load failed for $relationName using $fileName: " . $dbh->error_message); |
2994 |
Trace("Table load failed for $relationName.") if T(1); |
Trace("Table load failed for $relationName.") if T(1); |
2995 |
} else { |
} else { |
2996 |
# Here we successfully loaded the table. |
# Here we successfully loaded the table. |
2997 |
$retVal->Add("tables"); |
$retVal->Add("tables"); |
2998 |
my $size = -s $fileName; |
my $size = -s $fileName; |
2999 |
Trace("$size bytes loaded into $relationName.") if T(2); |
Trace("$size bytes loaded into $relationName.") if T(2); |
3000 |
|
$retVal->Add("bytes", $size); |
3001 |
# If we're rebuilding, we need to create the table indexes. |
# If we're rebuilding, we need to create the table indexes. |
3002 |
if ($truncateFlag) { |
if ($options{truncate}) { |
3003 |
# Indexes are created here for PostGres. For PostGres, indexes are |
# Indexes are created here for PostGres. For PostGres, indexes are |
3004 |
# best built at the end. For MySQL, the reverse is true. |
# best built at the end. For MySQL, the reverse is true. |
3005 |
if (! $dbh->{_preIndex}) { |
if (! $dbh->{_preIndex}) { |
3013 |
# The full-text index (if any) is always built last, even for MySQL. |
# The full-text index (if any) is always built last, even for MySQL. |
3014 |
# First we need to see if this table has a full-text index. Only |
# First we need to see if this table has a full-text index. Only |
3015 |
# primary relations are allowed that privilege. |
# primary relations are allowed that privilege. |
3016 |
|
Trace("Checking for full-text index on $relationName.") if T(2); |
3017 |
if ($self->_IsPrimary($relationName)) { |
if ($self->_IsPrimary($relationName)) { |
3018 |
# Get the relation's entity/relationship structure. |
$self->CreateSearchIndex($relationName); |
|
my $structure = $self->_GetStructure($relationName); |
|
|
# Check for a searchable fields list. |
|
|
if (exists $structure->{searchFields}) { |
|
|
# Here we know that we need to create a full-text search index. |
|
|
# Get an SQL-formatted field name list. |
|
|
my $fields = join(", ", $self->_FixNames(@{$structure->{searchFields}})); |
|
|
# Create the index. |
|
|
$dbh->create_index(tbl => $relationName, idx => "search_idx_$relationName", |
|
|
flds => $fields, kind => 'fulltext'); |
|
|
} |
|
3019 |
} |
} |
3020 |
} |
} |
3021 |
} |
} |
3022 |
# Analyze the table to improve performance. |
# Analyze the table to improve performance. |
3023 |
|
if (! $options{partial}) { |
3024 |
Trace("Analyzing and compacting $relationName.") if T(3); |
Trace("Analyzing and compacting $relationName.") if T(3); |
3025 |
$dbh->vacuum_it($relationName); |
$self->Analyze($relationName); |
3026 |
|
} |
3027 |
Trace("$relationName load completed.") if T(3); |
Trace("$relationName load completed.") if T(3); |
3028 |
# Return the statistics. |
# Return the statistics. |
3029 |
return $retVal; |
return $retVal; |
3030 |
} |
} |
3031 |
|
|
3032 |
=head3 GenerateEntity |
=head3 Analyze |
3033 |
|
|
3034 |
C<< my $fieldHash = $erdb->GenerateEntity($id, $type, \%values); >> |
$erdb->Analyze($tableName); |
3035 |
|
|
3036 |
Generate the data for a new entity instance. This method creates a field hash suitable for |
Analyze and compact a table in the database. This is useful after a load |
3037 |
passing as a parameter to L</InsertObject>. The ID is specified by the callr, but the rest |
to improve the performance of the indexes. |
|
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. |
|
3038 |
|
|
3039 |
=over 4 |
=over 4 |
3040 |
|
|
3041 |
=item id |
=item tableName |
|
|
|
|
ID to assign to the new entity. |
|
|
|
|
|
=item type |
|
3042 |
|
|
3043 |
Type name for the new entity. |
Name of the table to be analyzed and compacted. |
|
|
|
|
=item values |
|
|
|
|
|
Hash containing additional values that might be needed by the data generation methods (optional). |
|
3044 |
|
|
3045 |
=back |
=back |
3046 |
|
|
3047 |
=cut |
=cut |
3048 |
|
|
3049 |
sub GenerateEntity { |
sub Analyze { |
3050 |
# Get the parameters. |
# Get the parameters. |
3051 |
my ($self, $id, $type, $values) = @_; |
my ($self, $tableName) = @_; |
3052 |
# Create the return hash. |
# Analyze the table. |
3053 |
my $this = { id => $id }; |
$self->{_dbh}->vacuum_it($tableName); |
|
# Get the metadata structure. |
|
|
my $metadata = $self->{_metaData}; |
|
|
# Get this entity's list of fields. |
|
|
if (!exists $metadata->{Entities}->{$type}) { |
|
|
Confess("Unrecognized entity type $type in GenerateEntity."); |
|
|
} else { |
|
|
my $entity = $metadata->{Entities}->{$type}; |
|
|
my $fields = $entity->{Fields}; |
|
|
# Generate data from the fields. |
|
|
_GenerateFields($this, $fields, $type, $values); |
|
|
} |
|
|
# Return the hash created. |
|
|
return $this; |
|
3054 |
} |
} |
3055 |
|
|
3056 |
=head3 GetEntity |
=head3 TruncateTable |
3057 |
|
|
3058 |
C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >> |
$erdb->TruncateTable($table); |
3059 |
|
|
3060 |
Return an object describing the entity instance with a specified ID. |
Delete all rows from a table quickly. This uses the built-in SQL |
3061 |
|
C<TRUNCATE> statement, which effectively drops and re-creates a table |
3062 |
|
with all its settings intact. |
3063 |
|
|
3064 |
=over 4 |
=over 4 |
3065 |
|
|
3066 |
=item entityType |
=item table |
|
|
|
|
Entity type name. |
|
|
|
|
|
=item ID |
|
|
|
|
|
ID of the desired entity. |
|
|
|
|
|
=item RETURN |
|
3067 |
|
|
3068 |
Returns a B<DBObject> representing the desired entity instance, or an undefined value if no |
Name of the table to be cleared. |
|
instance is found with the specified key. |
|
3069 |
|
|
3070 |
=back |
=back |
3071 |
|
|
3072 |
=cut |
=cut |
3073 |
|
|
3074 |
sub GetEntity { |
sub TruncateTable { |
3075 |
# Get the parameters. |
# Get the parameters. |
3076 |
my ($self, $entityType, $ID) = @_; |
my ($self, $table) = @_; |
3077 |
# Create a query. |
# Get the database handle. |
3078 |
my $query = $self->Get([$entityType], "$entityType(id) = ?", [$ID]); |
my $dbh = $self->{_dbh}; |
3079 |
# Get the first (and only) object. |
# Execute a truncation comment. |
3080 |
my $retVal = $query->Fetch(); |
$dbh->SQL("TRUNCATE TABLE $table"); |
|
# Return the result. |
|
|
return $retVal; |
|
3081 |
} |
} |
3082 |
|
|
|
=head3 GetChoices |
|
3083 |
|
|
3084 |
C<< my @values = $erdb->GetChoices($entityName, $fieldName); >> |
=head3 CreateSearchIndex |
3085 |
|
|
3086 |
Return a list of all the values for the specified field that are represented in the |
$erdb->CreateSearchIndex($objectName); |
|
specified entity. |
|
3087 |
|
|
3088 |
Note that if the field is not indexed, then this will be a very slow operation. |
Check for a full-text search index on the specified entity or relationship object, and |
3089 |
|
if one is required, rebuild it. |
3090 |
|
|
3091 |
=over 4 |
=over 4 |
3092 |
|
|
3093 |
=item entityName |
=item objectName |
3094 |
|
|
3095 |
Name of an entity in the database. |
Name of the entity or relationship to be indexed. |
3096 |
|
|
3097 |
=item fieldName |
=back |
3098 |
|
|
3099 |
Name of a field belonging to the entity. This is a raw field name without |
=cut |
|
the standard parenthesized notation used in most calls. |
|
3100 |
|
|
3101 |
=item RETURN |
sub CreateSearchIndex { |
3102 |
|
# Get the parameters. |
3103 |
|
my ($self, $objectName) = @_; |
3104 |
|
# Get the relation's entity/relationship structure. |
3105 |
|
my $structure = $self->_GetStructure($objectName); |
3106 |
|
# Get the database handle. |
3107 |
|
my $dbh = $self->{_dbh}; |
3108 |
|
Trace("Checking for search fields in $objectName.") if T(3); |
3109 |
|
# Check for a searchable fields list. |
3110 |
|
if (exists $structure->{searchFields}) { |
3111 |
|
# Here we know that we need to create a full-text search index. |
3112 |
|
# Get an SQL-formatted field name list. |
3113 |
|
my $fields = join(", ", _FixNames(@{$structure->{searchFields}})); |
3114 |
|
# Create the index. If it already exists, it will be dropped. |
3115 |
|
$dbh->create_index(tbl => $objectName, idx => "search_idx", |
3116 |
|
flds => $fields, kind => 'fulltext'); |
3117 |
|
Trace("Index created for $fields in $objectName.") if T(2); |
3118 |
|
} |
3119 |
|
} |
3120 |
|
|
3121 |
Returns a list of the distinct values for the specified field in the database. |
=head3 DropRelation |
3122 |
|
|
3123 |
|
$erdb->DropRelation($relationName); |
3124 |
|
|
3125 |
|
Physically drop a relation from the database. |
3126 |
|
|
3127 |
|
=over 4 |
3128 |
|
|
3129 |
|
=item relationName |
3130 |
|
|
3131 |
|
Name of the relation to drop. If it does not exist, this method will have |
3132 |
|
no effect. |
3133 |
|
|
3134 |
=back |
=back |
3135 |
|
|
3136 |
=cut |
=cut |
3137 |
|
|
3138 |
sub GetChoices { |
sub DropRelation { |
3139 |
# Get the parameters. |
# Get the parameters. |
3140 |
my ($self, $entityName, $fieldName) = @_; |
my ($self, $relationName) = @_; |
3141 |
# Declare the return variable. |
# Get the database handle. |
3142 |
my @retVal; |
my $dbh = $self->{_dbh}; |
3143 |
# Get the entity data structure. |
# Drop the relation. The method used here has no effect if the relation |
3144 |
my $entityData = $self->_GetStructure($entityName); |
# does not exist. |
3145 |
# Get the field. |
Trace("Invoking DB Kernel to drop $relationName.") if T(3); |
3146 |
|
$dbh->drop_table(tbl => $relationName); |
3147 |
|
} |
3148 |
|
|
3149 |
|
=head3 MatchSqlPattern |
3150 |
|
|
3151 |
|
my $matched = ERDB::MatchSqlPattern($value, $pattern); |
3152 |
|
|
3153 |
|
Determine whether or not a specified value matches an SQL pattern. An SQL |
3154 |
|
pattern has two wild card characters: C<%> that matches multiple characters, |
3155 |
|
and C<_> that matches a single character. These can be escaped using a |
3156 |
|
backslash (C<\>). We pull this off by converting the SQL pattern to a |
3157 |
|
PERL regular expression. As per SQL rules, the match is case-insensitive. |
3158 |
|
|
3159 |
|
=over 4 |
3160 |
|
|
3161 |
|
=item value |
3162 |
|
|
3163 |
|
Value to be matched against the pattern. Note that an undefined or empty |
3164 |
|
value will not match anything. |
3165 |
|
|
3166 |
|
=item pattern |
3167 |
|
|
3168 |
|
SQL pattern against which to match the value. An undefined or empty pattern will |
3169 |
|
match everything. |
3170 |
|
|
3171 |
|
=item RETURN |
3172 |
|
|
3173 |
|
Returns TRUE if the value and pattern match, else FALSE. |
3174 |
|
|
3175 |
|
=back |
3176 |
|
|
3177 |
|
=cut |
3178 |
|
|
3179 |
|
sub MatchSqlPattern { |
3180 |
|
# Get the parameters. |
3181 |
|
my ($value, $pattern) = @_; |
3182 |
|
# Declare the return variable. |
3183 |
|
my $retVal; |
3184 |
|
# Insure we have a pattern. |
3185 |
|
if (! defined($pattern) || $pattern eq "") { |
3186 |
|
$retVal = 1; |
3187 |
|
} else { |
3188 |
|
# Break the pattern into pieces around the wildcard characters. Because we |
3189 |
|
# use parentheses in the split function's delimiter expression, we'll get |
3190 |
|
# list elements for the delimiters as well as the rest of the string. |
3191 |
|
my @pieces = split /([_%]|\\[_%])/, $pattern; |
3192 |
|
# Check some fast special cases. |
3193 |
|
if ($pattern eq '%') { |
3194 |
|
# A null pattern matches everything. |
3195 |
|
$retVal = 1; |
3196 |
|
} elsif (@pieces == 1) { |
3197 |
|
# No wildcards, so we have a literal comparison. Note we're case-insensitive. |
3198 |
|
$retVal = (lc($value) eq lc($pattern)); |
3199 |
|
} elsif (@pieces == 2 && $pieces[1] eq '%') { |
3200 |
|
# A wildcard at the end, so we have a substring match. This is also case-insensitive. |
3201 |
|
$retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0])); |
3202 |
|
} else { |
3203 |
|
# Okay, we have to do it the hard way. Convert each piece to a PERL pattern. |
3204 |
|
my $realPattern = ""; |
3205 |
|
for my $piece (@pieces) { |
3206 |
|
# Determine the type of piece. |
3207 |
|
if ($piece eq "") { |
3208 |
|
# Empty pieces are ignored. |
3209 |
|
} elsif ($piece eq "%") { |
3210 |
|
# Here we have a multi-character wildcard. Note that it can match |
3211 |
|
# zero or more characters. |
3212 |
|
$realPattern .= ".*" |
3213 |
|
} elsif ($piece eq "_") { |
3214 |
|
# Here we have a single-character wildcard. |
3215 |
|
$realPattern .= "."; |
3216 |
|
} elsif ($piece eq "\\%" || $piece eq "\\_") { |
3217 |
|
# This is an escape sequence (which is a rare thing, actually). |
3218 |
|
$realPattern .= substr($piece, 1, 1); |
3219 |
|
} else { |
3220 |
|
# Here we have raw text. |
3221 |
|
$realPattern .= quotemeta($piece); |
3222 |
|
} |
3223 |
|
} |
3224 |
|
# Do the match. |
3225 |
|
$retVal = ($value =~ /^$realPattern$/i ? 1 : 0); |
3226 |
|
} |
3227 |
|
} |
3228 |
|
# Return the result. |
3229 |
|
return $retVal; |
3230 |
|
} |
3231 |
|
|
3232 |
|
=head3 GetEntity |
3233 |
|
|
3234 |
|
my $entityObject = $erdb->GetEntity($entityType, $ID); |
3235 |
|
|
3236 |
|
Return an object describing the entity instance with a specified ID. |
3237 |
|
|
3238 |
|
=over 4 |
3239 |
|
|
3240 |
|
=item entityType |
3241 |
|
|
3242 |
|
Entity type name. |
3243 |
|
|
3244 |
|
=item ID |
3245 |
|
|
3246 |
|
ID of the desired entity. |
3247 |
|
|
3248 |
|
=item RETURN |
3249 |
|
|
3250 |
|
Returns a B<ERDBObject> representing the desired entity instance, or an undefined value if no |
3251 |
|
instance is found with the specified key. |
3252 |
|
|
3253 |
|
=back |
3254 |
|
|
3255 |
|
=cut |
3256 |
|
|
3257 |
|
sub GetEntity { |
3258 |
|
# Get the parameters. |
3259 |
|
my ($self, $entityType, $ID) = @_; |
3260 |
|
# Create a query. |
3261 |
|
my $query = $self->Get([$entityType], "$entityType(id) = ?", [$ID]); |
3262 |
|
# Get the first (and only) object. |
3263 |
|
my $retVal = $query->Fetch(); |
3264 |
|
if (T(3)) { |
3265 |
|
if ($retVal) { |
3266 |
|
Trace("Entity $entityType \"$ID\" found."); |
3267 |
|
} else { |
3268 |
|
Trace("Entity $entityType \"$ID\" not found."); |
3269 |
|
} |
3270 |
|
} |
3271 |
|
# Return the result. |
3272 |
|
return $retVal; |
3273 |
|
} |
3274 |
|
|
3275 |
|
=head3 GetChoices |
3276 |
|
|
3277 |
|
my @values = $erdb->GetChoices($entityName, $fieldName); |
3278 |
|
|
3279 |
|
Return a list of all the values for the specified field that are represented in the |
3280 |
|
specified entity. |
3281 |
|
|
3282 |
|
Note that if the field is not indexed, then this will be a very slow operation. |
3283 |
|
|
3284 |
|
=over 4 |
3285 |
|
|
3286 |
|
=item entityName |
3287 |
|
|
3288 |
|
Name of an entity in the database. |
3289 |
|
|
3290 |
|
=item fieldName |
3291 |
|
|
3292 |
|
Name of a field belonging to the entity. This is a raw field name without |
3293 |
|
the standard parenthesized notation used in most calls. |
3294 |
|
|
3295 |
|
=item RETURN |
3296 |
|
|
3297 |
|
Returns a list of the distinct values for the specified field in the database. |
3298 |
|
|
3299 |
|
=back |
3300 |
|
|
3301 |
|
=cut |
3302 |
|
|
3303 |
|
sub GetChoices { |
3304 |
|
# Get the parameters. |
3305 |
|
my ($self, $entityName, $fieldName) = @_; |
3306 |
|
# Declare the return variable. |
3307 |
|
my @retVal; |
3308 |
|
# Get the entity data structure. |
3309 |
|
my $entityData = $self->_GetStructure($entityName); |
3310 |
|
# Get the field. |
3311 |
my $fieldHash = $entityData->{Fields}; |
my $fieldHash = $entityData->{Fields}; |
3312 |
if (! exists $fieldHash->{$fieldName}) { |
if (! exists $fieldHash->{$fieldName}) { |
3313 |
Confess("$fieldName not found in $entityName."); |
Confess("$fieldName not found in $entityName."); |
3329 |
|
|
3330 |
=head3 GetEntityValues |
=head3 GetEntityValues |
3331 |
|
|
3332 |
C<< my @values = $erdb->GetEntityValues($entityType, $ID, \@fields); >> |
my @values = $erdb->GetEntityValues($entityType, $ID, \@fields); |
3333 |
|
|
3334 |
Return a list of values from a specified entity instance. If the entity instance |
Return a list of values from a specified entity instance. If the entity instance |
3335 |
does not exist, an empty list is returned. |
does not exist, an empty list is returned. |
3373 |
|
|
3374 |
=head3 GetAll |
=head3 GetAll |
3375 |
|
|
3376 |
C<< my @list = $erdb->GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count); >> |
my @list = $erdb->GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count); |
3377 |
|
|
3378 |
Return a list of values taken from the objects returned by a query. The first three |
Return a list of values taken from the objects returned by a query. The first three |
3379 |
parameters correspond to the parameters of the L</Get> method. The final parameter is |
parameters correspond to the parameters of the L</Get> method. The final parameter is |
3387 |
fields specified returns multiple values, they are flattened in with the rest. For |
fields specified returns multiple values, they are flattened in with the rest. For |
3388 |
example, the following call will return a list of the features in a particular |
example, the following call will return a list of the features in a particular |
3389 |
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 |
3390 |
feature ID followed by all of its aliases. |
feature ID followed by all of its essentiality determinations. |
3391 |
|
|
3392 |
C<< $query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(alias)']); >> |
@query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(essential)']); |
3393 |
|
|
3394 |
=over 4 |
=over 4 |
3395 |
|
|
3414 |
|
|
3415 |
List of the fields to be returned in each element of the list returned. |
List of the fields to be returned in each element of the list returned. |
3416 |
|
|
3417 |
=item count |
=item count |
3418 |
|
|
3419 |
|
Maximum number of records to return. If omitted or 0, all available records will be returned. |
3420 |
|
|
3421 |
|
=item RETURN |
3422 |
|
|
3423 |
|
Returns a list of list references. Each element of the return list contains the values for the |
3424 |
|
fields specified in the B<fields> parameter. |
3425 |
|
|
3426 |
|
=back |
3427 |
|
|
3428 |
|
=cut |
3429 |
|
#: Return Type @@; |
3430 |
|
sub GetAll { |
3431 |
|
# Get the parameters. |
3432 |
|
my ($self, $objectNames, $filterClause, $parameterList, $fields, $count) = @_; |
3433 |
|
# Translate the parameters from a list reference to a list. If the parameter |
3434 |
|
# list is a scalar we convert it into a singleton list. |
3435 |
|
my @parmList = (); |
3436 |
|
if (ref $parameterList eq "ARRAY") { |
3437 |
|
Trace("GetAll parm list is an array.") if T(4); |
3438 |
|
@parmList = @{$parameterList}; |
3439 |
|
} else { |
3440 |
|
Trace("GetAll parm list is a scalar: $parameterList.") if T(4); |
3441 |
|
push @parmList, $parameterList; |
3442 |
|
} |
3443 |
|
# Insure the counter has a value. |
3444 |
|
if (!defined $count) { |
3445 |
|
$count = 0; |
3446 |
|
} |
3447 |
|
# Add the row limit to the filter clause. |
3448 |
|
if ($count > 0) { |
3449 |
|
$filterClause .= " LIMIT $count"; |
3450 |
|
} |
3451 |
|
# Create the query. |
3452 |
|
my $query = $self->Get($objectNames, $filterClause, \@parmList); |
3453 |
|
# Set up a counter of the number of records read. |
3454 |
|
my $fetched = 0; |
3455 |
|
# Loop through the records returned, extracting the fields. Note that if the |
3456 |
|
# counter is non-zero, we stop when the number of records read hits the count. |
3457 |
|
my @retVal = (); |
3458 |
|
while (($count == 0 || $fetched < $count) && (my $row = $query->Fetch())) { |
3459 |
|
my @rowData = $row->Values($fields); |
3460 |
|
push @retVal, \@rowData; |
3461 |
|
$fetched++; |
3462 |
|
} |
3463 |
|
Trace("$fetched rows returned in GetAll.") if T(SQL => 4); |
3464 |
|
# Return the resulting list. |
3465 |
|
return @retVal; |
3466 |
|
} |
3467 |
|
|
3468 |
|
=head3 Exists |
3469 |
|
|
3470 |
|
my $found = $sprout->Exists($entityName, $entityID); |
3471 |
|
|
3472 |
|
Return TRUE if an entity exists, else FALSE. |
3473 |
|
|
3474 |
|
=over 4 |
3475 |
|
|
3476 |
|
=item entityName |
3477 |
|
|
3478 |
|
Name of the entity type (e.g. C<Feature>) relevant to the existence check. |
3479 |
|
|
3480 |
|
=item entityID |
3481 |
|
|
3482 |
|
ID of the entity instance whose existence is to be checked. |
3483 |
|
|
3484 |
|
=item RETURN |
3485 |
|
|
3486 |
|
Returns TRUE if the entity instance exists, else FALSE. |
3487 |
|
|
3488 |
|
=back |
3489 |
|
|
3490 |
|
=cut |
3491 |
|
#: Return Type $; |
3492 |
|
sub Exists { |
3493 |
|
# Get the parameters. |
3494 |
|
my ($self, $entityName, $entityID) = @_; |
3495 |
|
# Check for the entity instance. |
3496 |
|
Trace("Checking existence of $entityName with ID=$entityID.") if T(4); |
3497 |
|
my $testInstance = $self->GetEntity($entityName, $entityID); |
3498 |
|
# Return an existence indicator. |
3499 |
|
my $retVal = ($testInstance ? 1 : 0); |
3500 |
|
return $retVal; |
3501 |
|
} |
3502 |
|
|
3503 |
|
=head3 EstimateRowSize |
3504 |
|
|
3505 |
|
my $rowSize = $erdb->EstimateRowSize($relName); |
3506 |
|
|
3507 |
|
Estimate the row size of the specified relation. The estimated row size is computed by adding |
3508 |
|
up the average length for each data type. |
3509 |
|
|
3510 |
|
=over 4 |
3511 |
|
|
3512 |
|
=item relName |
3513 |
|
|
3514 |
|
Name of the relation whose estimated row size is desired. |
3515 |
|
|
3516 |
|
=item RETURN |
3517 |
|
|
3518 |
|
Returns an estimate of the row size for the specified relation. |
3519 |
|
|
3520 |
|
=back |
3521 |
|
|
3522 |
|
=cut |
3523 |
|
#: Return Type $; |
3524 |
|
sub EstimateRowSize { |
3525 |
|
# Get the parameters. |
3526 |
|
my ($self, $relName) = @_; |
3527 |
|
# Declare the return variable. |
3528 |
|
my $retVal = 0; |
3529 |
|
# Find the relation descriptor. |
3530 |
|
my $relation = $self->_FindRelation($relName); |
3531 |
|
# Get the list of fields. |
3532 |
|
for my $fieldData (@{$relation->{Fields}}) { |
3533 |
|
# Get the field type and add its length. |
3534 |
|
my $fieldLen = $TypeTable{$fieldData->{type}}->{avgLen}; |
3535 |
|
$retVal += $fieldLen; |
3536 |
|
} |
3537 |
|
# Return the result. |
3538 |
|
return $retVal; |
3539 |
|
} |
3540 |
|
|
3541 |
|
=head3 GetFieldTable |
3542 |
|
|
3543 |
|
my $fieldHash = $self->GetFieldTable($objectnName); |
3544 |
|
|
3545 |
|
Get the field structure for a specified entity or relationship. |
3546 |
|
|
3547 |
|
=over 4 |
3548 |
|
|
3549 |
|
=item objectName |
3550 |
|
|
3551 |
|
Name of the desired entity or relationship. |
3552 |
|
|
3553 |
|
=item RETURN |
3554 |
|
|
3555 |
|
The table containing the field descriptors for the specified object. |
3556 |
|
|
3557 |
|
=back |
3558 |
|
|
3559 |
|
=cut |
3560 |
|
|
3561 |
|
sub GetFieldTable { |
3562 |
|
# Get the parameters. |
3563 |
|
my ($self, $objectName) = @_; |
3564 |
|
# Get the descriptor from the metadata. |
3565 |
|
my $objectData = $self->_GetStructure($objectName); |
3566 |
|
# Return the object's field table. |
3567 |
|
return $objectData->{Fields}; |
3568 |
|
} |
3569 |
|
|
3570 |
|
=head3 SplitKeywords |
3571 |
|
|
3572 |
|
my @keywords = ERDB::SplitKeywords($keywordString); |
3573 |
|
|
3574 |
|
This method returns a list of the positive keywords in the specified |
3575 |
|
keyword string. All of the operators will have been stripped off, |
3576 |
|
and if the keyword is preceded by a minus operator (C<->), it will |
3577 |
|
not be in the list returned. The idea here is to get a list of the |
3578 |
|
keywords the user wants to see. The list will be processed to remove |
3579 |
|
duplicates. |
3580 |
|
|
3581 |
|
It is possible to create a string that confuses this method. For example |
3582 |
|
|
3583 |
|
frog toad -frog |
3584 |
|
|
3585 |
|
would return both C<frog> and C<toad>. If this is a problem we can deal |
3586 |
|
with it later. |
3587 |
|
|
3588 |
|
=over 4 |
3589 |
|
|
3590 |
|
=item keywordString |
3591 |
|
|
3592 |
|
The keyword string to be parsed. |
3593 |
|
|
3594 |
|
=item RETURN |
3595 |
|
|
3596 |
|
Returns a list of the words in the keyword string the user wants to |
3597 |
|
see. |
3598 |
|
|
3599 |
|
=back |
3600 |
|
|
3601 |
|
=cut |
3602 |
|
|
3603 |
|
sub SplitKeywords { |
3604 |
|
# Get the parameters. |
3605 |
|
my ($keywordString) = @_; |
3606 |
|
# Make a safety copy of the string. (This helps during debugging.) |
3607 |
|
my $workString = $keywordString; |
3608 |
|
# Convert operators we don't care about to spaces. |
3609 |
|
$workString =~ tr/+"()<>/ /; |
3610 |
|
# Split the rest of the string along space boundaries. Note that we |
3611 |
|
# eliminate any words that are zero length or begin with a minus sign. |
3612 |
|
my @wordList = grep { $_ && substr($_, 0, 1) ne "-" } split /\s+/, $workString; |
3613 |
|
# Use a hash to remove duplicates. |
3614 |
|
my %words = map { $_ => 1 } @wordList; |
3615 |
|
# Return the result. |
3616 |
|
return sort keys %words; |
3617 |
|
} |
3618 |
|
|
3619 |
|
=head3 ValidateFieldName |
3620 |
|
|
3621 |
|
my $okFlag = ERDB::ValidateFieldName($fieldName); |
3622 |
|
|
3623 |
|
Return TRUE if the specified field name is valid, else FALSE. Valid field names must |
3624 |
|
be hyphenated words subject to certain restrictions. |
3625 |
|
|
3626 |
|
=over 4 |
3627 |
|
|
3628 |
|
=item fieldName |
3629 |
|
|
3630 |
|
Field name to be validated. |
3631 |
|
|
3632 |
|
=item RETURN |
3633 |
|
|
3634 |
|
Returns TRUE if the field name is valid, else FALSE. |
3635 |
|
|
3636 |
|
=back |
3637 |
|
|
3638 |
|
=cut |
3639 |
|
|
3640 |
|
sub ValidateFieldName { |
3641 |
|
# Get the parameters. |
3642 |
|
my ($fieldName) = @_; |
3643 |
|
# Declare the return variable. The field name is valid until we hear |
3644 |
|
# differently. |
3645 |
|
my $retVal = 1; |
3646 |
|
# Compute the maximum name length. |
3647 |
|
my $maxLen = $TypeTable{'name-string'}->{maxLen}; |
3648 |
|
# Look for bad stuff in the name. |
3649 |
|
if ($fieldName =~ /--/) { |
3650 |
|
# Here we have a doubled minus sign. |
3651 |
|
Trace("Field name $fieldName has a doubled hyphen.") if T(1); |
3652 |
|
$retVal = 0; |
3653 |
|
} elsif ($fieldName !~ /^[A-Za-z]/) { |
3654 |
|
# Here the field name is missing the initial letter. |
3655 |
|
Trace("Field name $fieldName does not begin with a letter.") if T(1); |
3656 |
|
$retVal = 0; |
3657 |
|
} elsif (length($fieldName) > $maxLen) { |
3658 |
|
# Here the field name is too long. |
3659 |
|
Trace("Maximum field name length is $maxLen. Field name must be truncated to " . substr($fieldName,0, $maxLen) . "."); |
3660 |
|
} else { |
3661 |
|
# Strip out the minus signs. Everything remaining must be a letter, |
3662 |
|
# underscore, or digit. |
3663 |
|
my $strippedName = $fieldName; |
3664 |
|
$strippedName =~ s/-//g; |
3665 |
|
if ($strippedName !~ /^(\w|\d)+$/) { |
3666 |
|
Trace("Field name $fieldName contains illegal characters.") if T(1); |
3667 |
|
$retVal = 0; |
3668 |
|
} |
3669 |
|
} |
3670 |
|
# Return the result. |
3671 |
|
return $retVal; |
3672 |
|
} |
3673 |
|
|
3674 |
|
=head3 ReadMetaXML |
3675 |
|
|
3676 |
|
my $rawMetaData = ERDB::ReadDBD($fileName); |
3677 |
|
|
3678 |
|
This method reads a raw database definition XML file and returns it. |
3679 |
|
Normally, the metadata used by the ERDB system has been processed and |
3680 |
|
modified to make it easier to load and retrieve the data; however, |
3681 |
|
this method can be used to get the data in its raw form. |
3682 |
|
|
3683 |
|
=over 4 |
3684 |
|
|
3685 |
|
=item fileName |
3686 |
|
|
3687 |
|
Name of the XML file to read. |
3688 |
|
|
3689 |
|
=item RETURN |
3690 |
|
|
3691 |
|
Returns a hash reference containing the raw XML data from the specified file. |
3692 |
|
|
3693 |
|
=back |
3694 |
|
|
3695 |
|
=cut |
3696 |
|
|
3697 |
|
sub ReadMetaXML { |
3698 |
|
# Get the parameters. |
3699 |
|
my ($fileName) = @_; |
3700 |
|
# Read the XML. |
3701 |
|
my $retVal = XML::Simple::XMLin($fileName, %XmlOptions, %XmlInOpts); |
3702 |
|
Trace("XML metadata loaded from file $fileName.") if T(1); |
3703 |
|
# Return the result. |
3704 |
|
return $retVal; |
3705 |
|
} |
3706 |
|
|
3707 |
|
=head3 GetEntityFieldHash |
3708 |
|
|
3709 |
|
my $fieldHashRef = ERDB::GetEntityFieldHash($structure, $entityName); |
3710 |
|
|
3711 |
|
Get the field hash of the named entity in the specified raw XML structure. |
3712 |
|
The field hash may not exist, in which case we need to create it. |
3713 |
|
|
3714 |
|
=over 4 |
3715 |
|
|
3716 |
|
=item structure |
3717 |
|
|
3718 |
|
Raw XML structure defininng the database. This is not the run-time XML used by |
3719 |
|
an ERDB object, since that has all sorts of optimizations built-in. |
3720 |
|
|
3721 |
|
=item entityName |
3722 |
|
|
3723 |
|
Name of the entity whose field structure is desired. |
3724 |
|
|
3725 |
|
=item RETURN |
3726 |
|
|
3727 |
|
Returns the field hash used to define the entity's fields. |
3728 |
|
|
3729 |
|
=back |
3730 |
|
|
3731 |
|
=cut |
3732 |
|
|
3733 |
|
sub GetEntityFieldHash { |
3734 |
|
# Get the parameters. |
3735 |
|
my ($structure, $entityName) = @_; |
3736 |
|
# Get the entity structure. |
3737 |
|
my $entityData = $structure->{Entities}->{$entityName}; |
3738 |
|
# Look for a field structure. |
3739 |
|
my $retVal = $entityData->{Fields}; |
3740 |
|
# If it doesn't exist, create it. |
3741 |
|
if (! defined($retVal)) { |
3742 |
|
$entityData->{Fields} = {}; |
3743 |
|
$retVal = $entityData->{Fields}; |
3744 |
|
} |
3745 |
|
# Return the result. |
3746 |
|
return $retVal; |
3747 |
|
} |
3748 |
|
|
3749 |
|
=head3 WriteMetaXML |
3750 |
|
|
3751 |
|
ERDB::WriteMetaXML($structure, $fileName); |
3752 |
|
|
3753 |
|
Write the metadata XML to a file. This method is the reverse of L</ReadMetaXML>, and is |
3754 |
|
used to update the database definition. It must be used with care, however, since it |
3755 |
|
will only work on a raw structure, not on the processed structure created by an ERDB |
3756 |
|
constructor. |
3757 |
|
|
3758 |
|
=over 4 |
3759 |
|
|
3760 |
|
=item structure |
3761 |
|
|
3762 |
Maximum number of records to return. If omitted or 0, all available records will be returned. |
XML structure to be written to the file. |
3763 |
|
|
3764 |
=item RETURN |
=item fileName |
3765 |
|
|
3766 |
Returns a list of list references. Each element of the return list contains the values for the |
Name of the output file to which the updated XML should be stored. |
|
fields specified in the B<fields> parameter. |
|
3767 |
|
|
3768 |
=back |
=back |
3769 |
|
|
3770 |
=cut |
=cut |
3771 |
#: Return Type @@; |
|
3772 |
sub GetAll { |
sub WriteMetaXML { |
3773 |
# Get the parameters. |
# Get the parameters. |
3774 |
my ($self, $objectNames, $filterClause, $parameterList, $fields, $count) = @_; |
my ($structure, $fileName) = @_; |
3775 |
# Translate the parameters from a list reference to a list. If the parameter |
# Compute the output. |
3776 |
# list is a scalar we convert it into a singleton list. |
my $fileString = XML::Simple::XMLout($structure, %XmlOptions, %XmlOutOpts); |
3777 |
my @parmList = (); |
# Write it to the file. |
3778 |
if (ref $parameterList eq "ARRAY") { |
my $xmlOut = Open(undef, ">$fileName"); |
3779 |
Trace("GetAll parm list is an array.") if T(4); |
print $xmlOut $fileString; |
|
@parmList = @{$parameterList}; |
|
|
} else { |
|
|
Trace("GetAll parm list is a scalar: $parameterList.") if T(4); |
|
|
push @parmList, $parameterList; |
|
|
} |
|
|
# Insure the counter has a value. |
|
|
if (!defined $count) { |
|
|
$count = 0; |
|
|
} |
|
|
# Add the row limit to the filter clause. |
|
|
if ($count > 0) { |
|
|
$filterClause .= " LIMIT $count"; |
|
|
} |
|
|
# Create the query. |
|
|
my $query = $self->Get($objectNames, $filterClause, \@parmList); |
|
|
# Set up a counter of the number of records read. |
|
|
my $fetched = 0; |
|
|
# Loop through the records returned, extracting the fields. Note that if the |
|
|
# counter is non-zero, we stop when the number of records read hits the count. |
|
|
my @retVal = (); |
|
|
while (($count == 0 || $fetched < $count) && (my $row = $query->Fetch())) { |
|
|
my @rowData = $row->Values($fields); |
|
|
push @retVal, \@rowData; |
|
|
$fetched++; |
|
|
} |
|
|
Trace("$fetched rows returned in GetAll.") if T(SQL => 4); |
|
|
# Return the resulting list. |
|
|
return @retVal; |
|
3780 |
} |
} |
3781 |
|
|
|
=head3 Exists |
|
|
|
|
|
C<< my $found = $sprout->Exists($entityName, $entityID); >> |
|
3782 |
|
|
3783 |
Return TRUE if an entity exists, else FALSE. |
=head3 HTMLNote |
3784 |
|
|
3785 |
=over 4 |
Convert a note or comment to HTML by replacing some bulletin-board codes with HTML. The codes |
3786 |
|
supported are C<[b]> for B<bold>, C<[i]> for I<italics>, and C<[p]> for a new paragraph. |
3787 |
|
Except for C<[p]>, all the codes are closed by slash-codes. So, for |
3788 |
|
example, C<[b]Feature[/b]> displays the string C<Feature> in boldface. |
3789 |
|
|
3790 |
=item entityName |
my $realHtml = ERDB::HTMLNote($dataString); |
3791 |
|
|
3792 |
Name of the entity type (e.g. C<Feature>) relevant to the existence check. |
=over 4 |
3793 |
|
|
3794 |
=item entityID |
=item dataString |
3795 |
|
|
3796 |
ID of the entity instance whose existence is to be checked. |
String to convert to HTML. |
3797 |
|
|
3798 |
=item RETURN |
=item RETURN |
3799 |
|
|
3800 |
Returns TRUE if the entity instance exists, else FALSE. |
An HTML string derived from the input string. |
3801 |
|
|
3802 |
=back |
=back |
3803 |
|
|
3804 |
=cut |
=cut |
3805 |
#: Return Type $; |
|
3806 |
sub Exists { |
sub HTMLNote { |
3807 |
# Get the parameters. |
# Get the parameter. |
3808 |
my ($self, $entityName, $entityID) = @_; |
my ($dataString) = @_; |
3809 |
# Check for the entity instance. |
# HTML-escape the text. |
3810 |
Trace("Checking existence of $entityName with ID=$entityID.") if T(4); |
my $retVal = CGI::escapeHTML($dataString); |
3811 |
my $testInstance = $self->GetEntity($entityName, $entityID); |
# Substitute the bulletin board codes. |
3812 |
# Return an existence indicator. |
$retVal =~ s!\[(/?[bi])\]!<$1>!g; |
3813 |
my $retVal = ($testInstance ? 1 : 0); |
$retVal =~ s!\[p\]!</p><p>!g; |
3814 |
|
$retVal =~ s!\[link\s+([^\]]+)\]!<a href="$1">!g; |
3815 |
|
$retVal =~ s!\[/link\]!</a>!g; |
3816 |
|
# Return the result. |
3817 |
return $retVal; |
return $retVal; |
3818 |
} |
} |
3819 |
|
|
3820 |
=head3 EstimateRowSize |
=head3 WikiNote |
3821 |
|
|
3822 |
C<< my $rowSize = $erdb->EstimateRowSize($relName); >> |
Convert a note or comment to Wiki text by replacing some bulletin-board codes with HTML. The codes |
3823 |
|
supported are C<[b]> for B<bold>, C<[i]> for I<italics>, and C<[p]> for a new paragraph. |
3824 |
|
Except for C<[p]>, all the codes are closed by slash-codes. So, for |
3825 |
|
example, C<[b]Feature[/b]> displays the string C<Feature> in boldface. |
3826 |
|
|
3827 |
Estimate the row size of the specified relation. The estimated row size is computed by adding |
my $wikiText = ERDB::WikiNote($dataString); |
|
up the average length for each data type. |
|
3828 |
|
|
3829 |
=over 4 |
=over 4 |
3830 |
|
|
3831 |
=item relName |
=item dataString |
3832 |
|
|
3833 |
Name of the relation whose estimated row size is desired. |
String to convert to Wiki text. |
3834 |
|
|
3835 |
=item RETURN |
=item RETURN |
3836 |
|
|
3837 |
Returns an estimate of the row size for the specified relation. |
An Wiki text string derived from the input string. |
3838 |
|
|
3839 |
=back |
=back |
3840 |
|
|
3841 |
=cut |
=cut |
3842 |
#: Return Type $; |
|
3843 |
sub EstimateRowSize { |
sub WikiNote { |
3844 |
# Get the parameters. |
# Get the parameter. |
3845 |
my ($self, $relName) = @_; |
my ($dataString) = @_; |
3846 |
# Declare the return variable. |
# HTML-escape the text. |
3847 |
my $retVal = 0; |
my $retVal = CGI::escapeHTML($dataString); |
3848 |
# Find the relation descriptor. |
# Substitute the bulletin board codes. |
3849 |
my $relation = $self->_FindRelation($relName); |
my $italic = WikiTools::ItalicCode(); |
3850 |
# Get the list of fields. |
$retVal =~ s/\[\/?i\]/$italic/g; |
3851 |
for my $fieldData (@{$relation->{Fields}}) { |
my $bold = WikiTools::BoldCode(); |
3852 |
# Get the field type and add its length. |
$retVal =~ s/\[\/?b\]/$bold/g; |
3853 |
my $fieldLen = $TypeTable{$fieldData->{type}}->{avgLen}; |
# Paragraph breaks are the same no matter which Wiki you're using. |
3854 |
$retVal += $fieldLen; |
$retVal =~ s!\[p\]!\n\n!g; |
3855 |
|
# Now we do the links, which are complicated by the need to know two |
3856 |
|
# things: the target URL and the text. |
3857 |
|
while ($retVal =~ /\[link\s+([^\]]+)\]([^\[]+)\[\/link\]/g) { |
3858 |
|
# Replace the matched string with the Wiki markup for links. Note that |
3859 |
|
# $-[0] is the starting position of the match for the entire expression, |
3860 |
|
# and $+[0] is past the ending position. |
3861 |
|
substr $retVal, $-[0], $+[0] - $-[0], WikiTools::LinkMarkup($1, $2); |
3862 |
} |
} |
3863 |
# Return the result. |
# Return the result. |
3864 |
return $retVal; |
return $retVal; |
3865 |
} |
} |
3866 |
|
|
3867 |
=head3 GetFieldTable |
=head3 BeginTran |
3868 |
|
|
3869 |
C<< my $fieldHash = $self->GetFieldTable($objectnName); >> |
$erdb->BeginTran(); |
3870 |
|
|
3871 |
Get the field structure for a specified entity or relationship. |
Start a database transaction. |
3872 |
|
|
3873 |
|
=cut |
3874 |
|
|
3875 |
|
sub BeginTran { |
3876 |
|
my ($self) = @_; |
3877 |
|
$self->{_dbh}->begin_tran(); |
3878 |
|
|
3879 |
|
} |
3880 |
|
|
3881 |
|
=head3 CommitTran |
3882 |
|
|
3883 |
|
$erdb->CommitTran(); |
3884 |
|
|
3885 |
|
Commit an active database transaction. |
3886 |
|
|
3887 |
|
=cut |
3888 |
|
|
3889 |
|
sub CommitTran { |
3890 |
|
my ($self) = @_; |
3891 |
|
$self->{_dbh}->commit_tran(); |
3892 |
|
} |
3893 |
|
|
3894 |
|
=head3 RollbackTran |
3895 |
|
|
3896 |
|
$erdb->RollbackTran(); |
3897 |
|
|
3898 |
|
Roll back an active database transaction. |
3899 |
|
|
3900 |
|
=cut |
3901 |
|
|
3902 |
|
sub RollbackTran { |
3903 |
|
my ($self) = @_; |
3904 |
|
$self->{_dbh}->roll_tran(); |
3905 |
|
} |
3906 |
|
|
3907 |
|
=head3 UpdateField |
3908 |
|
|
3909 |
|
my $count = $erdb->UpdateField($objectNames, $fieldName, $oldValue, $newValue, $filter, $parms); |
3910 |
|
|
3911 |
|
Update all occurrences of a specific field value to a new value. The number of rows changed will be |
3912 |
|
returned. |
3913 |
|
|
3914 |
=over 4 |
=over 4 |
3915 |
|
|
3916 |
=item objectName |
=item fieldName |
3917 |
|
|
3918 |
Name of the desired entity or relationship. |
Name of the field in standard I<objectName>C<(>I<fieldName>C<)> format. |
3919 |
|
|
3920 |
|
=item oldValue |
3921 |
|
|
3922 |
|
Value to be modified. All occurrences of this value in the named field will be replaced by the |
3923 |
|
new value. |
3924 |
|
|
3925 |
|
=item newValue |
3926 |
|
|
3927 |
|
New value to be substituted for the old value when it's found. |
3928 |
|
|
3929 |
|
=item filter |
3930 |
|
|
3931 |
|
A standard ERDB filter clause (see L</Get>). The filter will be applied before any substitutions take place. |
3932 |
|
|
3933 |
|
=item parms |
3934 |
|
|
3935 |
|
Reference to a list of parameter values in the filter. |
3936 |
|
|
3937 |
=item RETURN |
=item RETURN |
3938 |
|
|
3939 |
The table containing the field descriptors for the specified object. |
Returns the number of rows modified. |
3940 |
|
|
3941 |
=back |
=back |
3942 |
|
|
3943 |
=cut |
=cut |
3944 |
|
|
3945 |
sub GetFieldTable { |
sub UpdateField { |
3946 |
# Get the parameters. |
# Get the parameters. |
3947 |
my ($self, $objectName) = @_; |
my ($self, $fieldName, $oldValue, $newValue, $filter, $parms) = @_; |
3948 |
# Get the descriptor from the metadata. |
# Get the object and field names from the field name parameter. |
3949 |
my $objectData = $self->_GetStructure($objectName); |
$fieldName =~ /^([^(]+)\(([^)]+)\)/; |
3950 |
# Return the object's field table. |
my $objectName = $1; |
3951 |
return $objectData->{Fields}; |
my $realFieldName = _FixName($2); |
3952 |
|
# Add the old value to the filter. Note we allow the possibility that no |
3953 |
|
# filter was specified. |
3954 |
|
my $realFilter = "$fieldName = ?"; |
3955 |
|
if ($filter) { |
3956 |
|
$realFilter .= " AND $filter"; |
3957 |
|
} |
3958 |
|
# Format the query filter. |
3959 |
|
my ($suffix, $mappedNameListRef, $mappedNameHashRef) = |
3960 |
|
$self->_SetupSQL([$objectName], $realFilter); |
3961 |
|
# Create the query. Since there is only one object name, the mapped-name data is not |
3962 |
|
# necessary. Neither is the FROM clause. |
3963 |
|
$suffix =~ s/^FROM.+WHERE\s+//; |
3964 |
|
# Create the update statement. |
3965 |
|
my $command = "UPDATE $objectName SET $realFieldName = ? WHERE $suffix"; |
3966 |
|
# Get the database handle. |
3967 |
|
my $dbh = $self->{_dbh}; |
3968 |
|
# Add the old and new values to the parameter list. Note we allow the possibility that |
3969 |
|
# there are no user-supplied parameters. |
3970 |
|
my @params = ($newValue, $oldValue); |
3971 |
|
if (defined $parms) { |
3972 |
|
push @params, @{$parms}; |
3973 |
|
} |
3974 |
|
# Execute the update. |
3975 |
|
my $retVal = $dbh->SQL($command, 0, @params); |
3976 |
|
# Make the funky zero a real zero. |
3977 |
|
if ($retVal == 0) { |
3978 |
|
$retVal = 0; |
3979 |
|
} |
3980 |
|
# Return the result. |
3981 |
|
return $retVal; |
3982 |
} |
} |
3983 |
|
|
3984 |
|
|
3985 |
=head2 Data Mining Methods |
=head2 Data Mining Methods |
3986 |
|
|
3987 |
=head3 GetUsefulCrossValues |
=head3 GetUsefulCrossValues |
3988 |
|
|
3989 |
C<< my @attrNames = $sprout->GetUsefulCrossValues($sourceEntity, $relationship); >> |
my @attrNames = $sprout->GetUsefulCrossValues($sourceEntity, $relationship); |
3990 |
|
|
3991 |
Return a list of the useful attributes that would be returned by a B<Cross> call |
Return a list of the useful attributes that would be returned by a B<Cross> call |
3992 |
from an entity of the source entity type through the specified relationship. This |
from an entity of the source entity type through the specified relationship. This |
4047 |
|
|
4048 |
=head3 FindColumn |
=head3 FindColumn |
4049 |
|
|
4050 |
C<< my $colIndex = ERDB::FindColumn($headerLine, $columnIdentifier); >> |
my $colIndex = ERDB::FindColumn($headerLine, $columnIdentifier); |
4051 |
|
|
4052 |
Return the location a desired column in a data mining header line. The data |
Return the location a desired column in a data mining header line. The data |
4053 |
mining header line is a tab-separated list of column names. The column |
mining header line is a tab-separated list of column names. The column |
4105 |
|
|
4106 |
=head3 ParseColumns |
=head3 ParseColumns |
4107 |
|
|
4108 |
C<< my @columns = ERDB::ParseColumns($line); >> |
my @columns = ERDB::ParseColumns($line); |
4109 |
|
|
4110 |
Convert the specified data line to a list of columns. |
Convert the specified data line to a list of columns. |
4111 |
|
|
4137 |
|
|
4138 |
=head2 Virtual Methods |
=head2 Virtual Methods |
4139 |
|
|
4140 |
|
=head3 _CreatePPOIndex |
4141 |
|
|
4142 |
|
my $index = ERDB::_CreatePPOIndex($indexObject); |
4143 |
|
|
4144 |
|
Convert the XML for an ERDB index to the XML structure for a PPO |
4145 |
|
index. |
4146 |
|
|
4147 |
|
=over 4 |
4148 |
|
|
4149 |
|
=item indexObject |
4150 |
|
|
4151 |
|
ERDB XML structure for an index. |
4152 |
|
|
4153 |
|
=item RETURN |
4154 |
|
|
4155 |
|
PPO XML structure for the same index. |
4156 |
|
|
4157 |
|
=back |
4158 |
|
|
4159 |
|
=cut |
4160 |
|
|
4161 |
|
sub _CreatePPOIndex { |
4162 |
|
# Get the parameters. |
4163 |
|
my ($indexObject) = @_; |
4164 |
|
# The incoming index contains a list of the index fields in the IndexFields |
4165 |
|
# member. We loop through it to create the index tags. |
4166 |
|
my @fields = map { { label => _FixName($_->{name}) } } @{$indexObject->{IndexFields}}; |
4167 |
|
# Wrap the fields in attribute tags. |
4168 |
|
my $retVal = { attribute => \@fields }; |
4169 |
|
# Return the result. |
4170 |
|
return $retVal; |
4171 |
|
} |
4172 |
|
|
4173 |
|
=head3 _CreatePPOField |
4174 |
|
|
4175 |
|
my $fieldXML = ERDB::_CreatePPOField($fieldName, $fieldObject); |
4176 |
|
|
4177 |
|
Convert the ERDB XML structure for a field to a PPO scalar XML structure. |
4178 |
|
|
4179 |
|
=over 4 |
4180 |
|
|
4181 |
|
=item fieldName |
4182 |
|
|
4183 |
|
Name of the scalar field. |
4184 |
|
|
4185 |
|
=item fieldObject |
4186 |
|
|
4187 |
|
ERDB XML structure describing the field. |
4188 |
|
|
4189 |
|
=item RETURN |
4190 |
|
|
4191 |
|
Returns a PPO XML structure for the same field. |
4192 |
|
|
4193 |
|
=back |
4194 |
|
|
4195 |
|
=cut |
4196 |
|
|
4197 |
|
sub _CreatePPOField { |
4198 |
|
# Get the parameters. |
4199 |
|
my ($fieldName, $fieldObject) = @_; |
4200 |
|
# Get the field type. |
4201 |
|
my $type = $TypeTable{$fieldObject->{type}}->{sqlType}; |
4202 |
|
# Fix up the field name. |
4203 |
|
$fieldName = _FixName($fieldName); |
4204 |
|
# Build the scalar tag. |
4205 |
|
my $retVal = { label => $fieldName, type => $type }; |
4206 |
|
# Return the result. |
4207 |
|
return $retVal; |
4208 |
|
} |
4209 |
|
|
4210 |
=head3 CleanKeywords |
=head3 CleanKeywords |
4211 |
|
|
4212 |
C<< my $cleanedString = $erdb->CleanKeywords($searchExpression); >> |
my $cleanedString = $erdb->CleanKeywords($searchExpression); |
4213 |
|
|
4214 |
Clean up a search expression or keyword list. This is a virtual method that may |
Clean up a search expression or keyword list. This is a virtual method that may |
4215 |
be overridden by the subclass. The base-class method removes extra spaces |
be overridden by the subclass. The base-class method removes extra spaces |
4244 |
return $retVal; |
return $retVal; |
4245 |
} |
} |
4246 |
|
|
4247 |
|
=head3 GetSourceObject |
4248 |
|
|
4249 |
|
my $source = $erdb->GetSourceObject($entityName); |
4250 |
|
|
4251 |
|
Return the object to be used in loading special attributes of the specified entity. The |
4252 |
|
algorithm for loading special attributes is stored in the C<DataGen> elements of the |
4253 |
|
XML |
4254 |
|
|
4255 |
=head2 Internal Utility Methods |
=head2 Internal Utility Methods |
4256 |
|
|
4257 |
=head3 _RelationMap |
=head3 _RelationMap |
4258 |
|
|
4259 |
C<< my @relationMap = _RelationMap($mappedNameHashRef, $mappedNameListRef); >> |
my @relationMap = _RelationMap($mappedNameHashRef, $mappedNameListRef); |
4260 |
|
|
4261 |
Create the relation map for an SQL query. The relation map is used by B<DBObject> |
Create the relation map for an SQL query. The relation map is used by B<ERDBObject> |
4262 |
to determine how to interpret the results of the query. |
to determine how to interpret the results of the query. |
4263 |
|
|
4264 |
=over 4 |
=over 4 |
4275 |
=item RETURN |
=item RETURN |
4276 |
|
|
4277 |
Returns a list of 2-tuples. Each tuple consists of an object name as used in the |
Returns a list of 2-tuples. Each tuple consists of an object name as used in the |
4278 |
query followed by the actual name of that object. This enables the B<DBObject> to |
query followed by the actual name of that object. This enables the B<ERDBObject> to |
4279 |
determine the order of the tables in the query and which object name belongs to each |
determine the order of the tables in the query and which object name belongs to each |
4280 |
mapped object name. Most of the time these two values are the same; however, if a |
mapped object name. Most of the time these two values are the same; however, if a |
4281 |
relation occurs twice in the query, the relation name in the field list and WHERE |
relation occurs twice in the query, the relation name in the field list and WHERE |
4569 |
sub _GetStatementHandle { |
sub _GetStatementHandle { |
4570 |
# Get the parameters. |
# Get the parameters. |
4571 |
my ($self, $command, $params) = @_; |
my ($self, $command, $params) = @_; |
4572 |
|
Confess("Invalid parameter list.") if (! defined($params) || ref($params) ne 'ARRAY'); |
4573 |
# Trace the query. |
# Trace the query. |
4574 |
Trace("SQL query: $command") if T(SQL => 3); |
Trace("SQL query: $command") if T(SQL => 3); |
4575 |
Trace("PARMS: '" . (join "', '", @{$params}) . "'") if (T(SQL => 4) && (@{$params} > 0)); |
Trace("PARMS: '" . (join "', '", @{$params}) . "'") if (T(SQL => 4) && (@{$params} > 0)); |
4578 |
# Prepare the command. |
# Prepare the command. |
4579 |
my $sth = $dbh->prepare_command($command); |
my $sth = $dbh->prepare_command($command); |
4580 |
# Execute it with the parameters bound in. |
# Execute it with the parameters bound in. |
4581 |
$sth->execute(@{$params}) || Confess("SELECT error" . $sth->errstr()); |
$sth->execute(@{$params}) || Confess("SELECT error: " . $sth->errstr()); |
4582 |
# Return the statement handle. |
# Return the statement handle. |
4583 |
return $sth; |
return $sth; |
4584 |
} |
} |
4595 |
return Stats->new(); |
return Stats->new(); |
4596 |
} |
} |
4597 |
|
|
|
=head3 _GenerateFields |
|
|
|
|
|
Generate field values from a field structure and store in a specified table. The field names |
|
|
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. |
|
|
|
|
|
This is a static method. |
|
|
|
|
|
=over 4 |
|
|
|
|
|
=item this |
|
|
|
|
|
Hash table into which the field values should be placed. |
|
|
|
|
|
=item fields |
|
|
|
|
|
Field structure from which the field descriptors should be taken. |
|
|
|
|
|
=item type |
|
|
|
|
|
Type name of the object whose fields are being generated. |
|
|
|
|
|
=item values (optional) |
|
|
|
|
|
Reference to a value structure from which additional values can be taken. |
|
|
|
|
|
=item from (optiona) |
|
|
|
|
|
Reference to the source entity instance if relationship data is being generated. |
|
|
|
|
|
=item to (optional) |
|
|
|
|
|
Reference to the target entity instance if relationship data is being generated. |
|
|
|
|
|
=back |
|
|
|
|
|
=cut |
|
|
|
|
|
sub _GenerateFields { |
|
|
# Get the parameters. |
|
|
my ($this, $fields, $type, $values, $from, $to) = @_; |
|
|
# Sort the field names by pass number. |
|
|
my @fieldNames = sort { $fields->{$a}->{DataGen}->{pass} <=> $fields->{$b}->{DataGen}->{pass} } keys %{$fields}; |
|
|
# Loop through the field names, generating data. |
|
|
for my $name (@fieldNames) { |
|
|
# Only proceed if this field needs to be generated. |
|
|
if (!exists $this->{$name}) { |
|
|
# Get this field's data generation descriptor. |
|
|
my $fieldDescriptor = $fields->{$name}; |
|
|
my $data = $fieldDescriptor->{DataGen}; |
|
|
# Get the code to generate the field value. |
|
|
my $codeString = $data->{content}; |
|
|
# Determine whether or not this field is in the primary relation. |
|
|
if ($fieldDescriptor->{relation} eq $type) { |
|
|
# Here we have a primary relation field. Store the field value as |
|
|
# a scalar. |
|
|
$this->{$name} = eval($codeString); |
|
|
} else { |
|
|
# Here we have a secondary relation field. Create a null list |
|
|
# and push the desired number of field values onto it. |
|
|
my @fieldValues = (); |
|
|
my $count = IntGen(0,$data->{testCount}); |
|
|
for (my $i = 0; $i < $count; $i++) { |
|
|
my $newValue = eval($codeString); |
|
|
push @fieldValues, $newValue; |
|
|
} |
|
|
# Store the value list in the main hash. |
|
|
$this->{$name} = \@fieldValues; |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
4598 |
=head3 _DumpRelation |
=head3 _DumpRelation |
4599 |
|
|
4600 |
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. |
4601 |
|
|
4602 |
This is an instance method. |
This is an instance method. |
4603 |
|
|
4742 |
for my $object (values %{$metadata->{$section}}) { |
for my $object (values %{$metadata->{$section}}) { |
4743 |
# Loop through the object's fields. |
# Loop through the object's fields. |
4744 |
for my $fieldName (keys %{$object->{Fields}}) { |
for my $fieldName (keys %{$object->{Fields}}) { |
4745 |
# Now we make some initial validations. |
# If this field name is invalid, set the return value to zero |
4746 |
if ($fieldName =~ /--/) { |
# so we know we encountered an error. |
4747 |
# 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"; |
|
4748 |
$retVal = 0; |
$retVal = 0; |
4749 |
} |
} |
4750 |
} |
} |
4751 |
} |
} |
4752 |
} |
} |
|
} |
|
4753 |
# If an error was found, fail. |
# If an error was found, fail. |
4754 |
if ($retVal == 0) { |
if ($retVal == 0) { |
4755 |
Confess("Errors found in field names."); |
Confess("Errors found in field names."); |
4807 |
# be a null string. |
# be a null string. |
4808 |
if ($fileName ne "") { |
if ($fileName ne "") { |
4809 |
# Load the relation from the file. |
# Load the relation from the file. |
4810 |
$retVal = $self->LoadTable($fileName, $relationName, $rebuild); |
$retVal = $self->LoadTable($fileName, $relationName, truncate => $rebuild); |
4811 |
} elsif ($rebuild) { |
} elsif ($rebuild) { |
4812 |
# Here we are rebuilding, but no file exists, so we just re-create the table. |
# Here we are rebuilding, but no file exists, so we just re-create the table. |
4813 |
$self->CreateTable($relationName, 1); |
$self->CreateTable($relationName, 1); |
4816 |
return $retVal; |
return $retVal; |
4817 |
} |
} |
4818 |
|
|
4819 |
|
|
4820 |
=head3 _LoadMetaData |
=head3 _LoadMetaData |
4821 |
|
|
4822 |
|
my $metadata = ERDB::_LoadMetaData($filename); |
4823 |
|
|
4824 |
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. |
4825 |
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 |
4826 |
load or use the database. The schema for the XML file is F<ERDatabase.xml>. |
load or use the database. The schema for the XML file is F<ERDatabase.xml>. |
4844 |
sub _LoadMetaData { |
sub _LoadMetaData { |
4845 |
# Get the parameters. |
# Get the parameters. |
4846 |
my ($filename) = @_; |
my ($filename) = @_; |
4847 |
Trace("Reading Sprout DBD from $filename.") if T(2); |
Trace("Reading DBD from $filename.") if T(2); |
4848 |
# 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 |
4849 |
# get the exact structure we want. |
# get the exact structure we want. |
4850 |
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); |
|
4851 |
# 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, |
4852 |
# the method below will fail. |
# the method below will fail. |
4853 |
_ValidateFieldNames($metadata); |
_ValidateFieldNames($metadata); |
4970 |
if ($found == 0) { |
if ($found == 0) { |
4971 |
push @{$indexList}, { IndexFields => [ {name => 'id', order => 'ascending'} ] }; |
push @{$indexList}, { IndexFields => [ {name => 'id', order => 'ascending'} ] }; |
4972 |
} |
} |
4973 |
# Now we need to convert the relation's index list to an index table. We begin by creating |
# Attach all the indexes to the relation. |
4974 |
# an empty table in the relation structure. |
_ProcessIndexes($indexList, $relation); |
|
$relation->{Indexes} = { }; |
|
|
# Loop through the indexes. |
|
|
my $count = 0; |
|
|
for my $index (@{$indexList}) { |
|
|
# Add this index to the index table. |
|
|
_AddIndex("idx$relationName$count", $relation, $index); |
|
|
# Increment the counter so that the next index has a different name. |
|
|
$count++; |
|
|
} |
|
4975 |
} |
} |
4976 |
# Finally, we add the relation structure to the entity. |
# Finally, we add the relation structure to the entity. |
4977 |
$entityStructure->{Relations} = $relationTable; |
$entityStructure->{Relations} = $relationTable; |
4985 |
_FixupFields($relationshipStructure, $relationshipName, 2, 3); |
_FixupFields($relationshipStructure, $relationshipName, 2, 3); |
4986 |
# Format a description for the FROM field. |
# Format a description for the FROM field. |
4987 |
my $fromEntity = $relationshipStructure->{from}; |
my $fromEntity = $relationshipStructure->{from}; |
4988 |
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]."; |
4989 |
# Get the FROM entity's key type. |
# Get the FROM entity's key type. |
4990 |
my $fromType = $entityList->{$fromEntity}->{keyType}; |
my $fromType = $entityList->{$fromEntity}->{keyType}; |
4991 |
# Add the FROM field. |
# Add the FROM field. |
4995 |
PrettySort => 1}); |
PrettySort => 1}); |
4996 |
# Format a description for the TO field. |
# Format a description for the TO field. |
4997 |
my $toEntity = $relationshipStructure->{to}; |
my $toEntity = $relationshipStructure->{to}; |
4998 |
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]."; |
4999 |
# Get the TO entity's key type. |
# Get the TO entity's key type. |
5000 |
my $toType = $entityList->{$toEntity}->{keyType}; |
my $toType = $entityList->{$toEntity}->{keyType}; |
5001 |
# Add the TO field. |
# Add the TO field. |
5007 |
my $thisRelation = { Fields => _ReOrderRelationTable($relationshipStructure->{Fields}), |
my $thisRelation = { Fields => _ReOrderRelationTable($relationshipStructure->{Fields}), |
5008 |
Indexes => { } }; |
Indexes => { } }; |
5009 |
$relationshipStructure->{Relations} = { $relationshipName => $thisRelation }; |
$relationshipStructure->{Relations} = { $relationshipName => $thisRelation }; |
5010 |
|
|
5011 |
|
# Add the alternate indexes (if any). This MUST be done before the FROM and |
5012 |
|
# TO indexes, because it erases the relation's index list. |
5013 |
|
if (exists $relationshipStructure->{Indexes}) { |
5014 |
|
_ProcessIndexes($relationshipStructure->{Indexes}, $thisRelation); |
5015 |
|
} |
5016 |
|
# Add the relation to the master table. |
5017 |
# Create the FROM and TO indexes. |
# Create the FROM and TO indexes. |
5018 |
_CreateRelationshipIndex("From", $relationshipName, $relationshipStructure); |
_CreateRelationshipIndex("From", $relationshipName, $relationshipStructure); |
5019 |
_CreateRelationshipIndex("To", $relationshipName, $relationshipStructure); |
_CreateRelationshipIndex("To", $relationshipName, $relationshipStructure); |
|
# Add the relation to the master table. |
|
5020 |
$masterRelationTable{$relationshipName} = $thisRelation; |
$masterRelationTable{$relationshipName} = $thisRelation; |
5021 |
} |
} |
5022 |
# Now store the master relation table in the metadata structure. |
# Now store the master relation table in the metadata structure. |
5172 |
$newIndex->{Unique} = 'true'; |
$newIndex->{Unique} = 'true'; |
5173 |
} |
} |
5174 |
# Add the index to the relation. |
# Add the index to the relation. |
5175 |
_AddIndex("idx$relationshipName$indexKey", $relationStructure, $newIndex); |
_AddIndex("idx$indexKey", $relationStructure, $newIndex); |
5176 |
|
} |
5177 |
|
|
5178 |
|
=head3 _ProcessIndexes |
5179 |
|
|
5180 |
|
ERDB::_ProcessIndexes($indexList, $relation); |
5181 |
|
|
5182 |
|
Build the data structures for the specified indexes in the specified relation. |
5183 |
|
|
5184 |
|
=over 4 |
5185 |
|
|
5186 |
|
=item indexList |
5187 |
|
|
5188 |
|
Reference to a list of indexes. Each index is a hash reference containing an optional |
5189 |
|
C<Notes> value that describes the index and an C<IndexFields> value that is a reference |
5190 |
|
to a list of index field structures. An index field structure, in turn, is a reference |
5191 |
|
to a hash that contains a C<name> attribute for the field name and an C<order> |
5192 |
|
attribute that specifies either C<ascending> or C<descending>. In this sense the |
5193 |
|
index list encapsulates the XML C<Indexes> structure in the database definition. |
5194 |
|
|
5195 |
|
=item relation |
5196 |
|
|
5197 |
|
The structure that describes the current relation. The new index descriptors will |
5198 |
|
be stored in the structure's C<Indexes> member. Any previous data in the structure |
5199 |
|
will be lost. |
5200 |
|
|
5201 |
|
=back |
5202 |
|
|
5203 |
|
=cut |
5204 |
|
|
5205 |
|
sub _ProcessIndexes { |
5206 |
|
# Get the parameters. |
5207 |
|
my ($indexList, $relation) = @_; |
5208 |
|
# Now we need to convert the relation's index list to an index table. We begin by creating |
5209 |
|
# an empty table in the relation structure. |
5210 |
|
$relation->{Indexes} = { }; |
5211 |
|
# Loop through the indexes. |
5212 |
|
my $count = 0; |
5213 |
|
for my $index (@{$indexList}) { |
5214 |
|
# Add this index to the index table. |
5215 |
|
_AddIndex("idx$count", $relation, $index); |
5216 |
|
# Increment the counter so that the next index has a different name. |
5217 |
|
$count++; |
5218 |
|
} |
5219 |
} |
} |
5220 |
|
|
5221 |
=head3 _AddIndex |
=head3 _AddIndex |
5314 |
my $type = $fieldData->{type}; |
my $type = $fieldData->{type}; |
5315 |
# Plug in a relation name if it is needed. |
# Plug in a relation name if it is needed. |
5316 |
Tracer::MergeOptions($fieldData, { relation => $defaultRelationName }); |
Tracer::MergeOptions($fieldData, { relation => $defaultRelationName }); |
|
# Plug in a data generator if we need one. |
|
|
if (!exists $fieldData->{DataGen}) { |
|
|
# The data generator will use the default for the field's type. |
|
|
$fieldData->{DataGen} = { content => $TypeTable{$type}->{dataGen} }; |
|
|
} |
|
5317 |
# Check for searchability. |
# Check for searchability. |
5318 |
if ($fieldData->{searchable}) { |
if ($fieldData->{searchable}) { |
5319 |
# Only allow this for a primary relation. |
# Only allow this for a primary relation. |
5323 |
push @textFields, $fieldName; |
push @textFields, $fieldName; |
5324 |
} |
} |
5325 |
} |
} |
|
# Plug in the defaults for the optional data generation parameters. |
|
|
Tracer::MergeOptions($fieldData->{DataGen}, { testCount => 1, pass => 0 }); |
|
5326 |
# Add the PrettySortValue. |
# Add the PrettySortValue. |
5327 |
$fieldData->{PrettySort} = (($type eq "text") ? $textPrettySortValue : $prettySortValue); |
$fieldData->{PrettySort} = (($type eq "text") ? $textPrettySortValue : $prettySortValue); |
5328 |
} |
} |
5554 |
return $retVal; |
return $retVal; |
5555 |
} |
} |
5556 |
|
|
5557 |
=head2 HTML Documentation Utility Methods |
=head2 Documentation Utility Methods |
5558 |
|
|
5559 |
=head3 _ComputeRelationshipSentence |
=head3 _ComputeRelationshipSentence |
5560 |
|
|
5586 |
# Get the parameters. |
# Get the parameters. |
5587 |
my ($relationshipName, $relationshipStructure) = @_; |
my ($relationshipName, $relationshipStructure) = @_; |
5588 |
# Format the relationship sentence. |
# Format the relationship sentence. |
5589 |
my $result = "$relationshipStructure->{from} <b>$relationshipName</b> $relationshipStructure->{to}"; |
my $result = "$relationshipStructure->{from} $relationshipName $relationshipStructure->{to}"; |
5590 |
# Compute the arity. |
# Compute the arity. |
5591 |
my $arityCode = $relationshipStructure->{arity}; |
my $arityCode = $relationshipStructure->{arity}; |
5592 |
my $arity = $ArityTable{$arityCode}; |
my $arity = $ArityTable{$arityCode}; |
5631 |
return $result; |
return $result; |
5632 |
} |
} |
5633 |
|
|
5634 |
|
=head3 _WikiRelationTable |
5635 |
|
|
5636 |
|
Generate the Wiki text for a particular relation. The relation's data will be formatted as a |
5637 |
|
table with three columns-- the field name, the field type, and the field description. |
5638 |
|
|
5639 |
|
This is a static method. |
5640 |
|
|
5641 |
|
=over 4 |
5642 |
|
|
5643 |
|
=item relationName |
5644 |
|
|
5645 |
|
Name of the relation being formatted. |
5646 |
|
|
5647 |
|
=item relationData |
5648 |
|
|
5649 |
|
Hash containing the relation's fields and indexes. |
5650 |
|
|
5651 |
|
=item RETURN |
5652 |
|
|
5653 |
|
Returns a Wiki string that can be used to display the relation name and all of its fields. |
5654 |
|
|
5655 |
|
=back |
5656 |
|
|
5657 |
|
=cut |
5658 |
|
|
5659 |
|
sub _WikiRelationTable { |
5660 |
|
# Get the parameters. |
5661 |
|
my ($relationName, $relationData) = @_; |
5662 |
|
# We'll create a list of lists in here, then call WikiTools::Table to |
5663 |
|
# convert it into a table. |
5664 |
|
my @rows = (); |
5665 |
|
# Push in the header row. |
5666 |
|
push @rows, [qw(Field Type Description)]; |
5667 |
|
# Loop through the fields. |
5668 |
|
for my $field (@{$relationData->{Fields}}) { |
5669 |
|
# Create this field's row. We always have a name and type. |
5670 |
|
my @row = ($field->{name}, $field->{type}); |
5671 |
|
# If we have a description, add it as the third column. |
5672 |
|
if (exists $field->{Notes}) { |
5673 |
|
push @row, WikiNote($field->{Notes}->{content}); |
5674 |
|
} |
5675 |
|
# Push this row onto the table list. |
5676 |
|
push @rows, \@row; |
5677 |
|
} |
5678 |
|
# Store the rows as a Wiki table with a level-4 heading. |
5679 |
|
my $retVal = join("\n\n", WikiTools::Heading(4, "$relationName Table"), |
5680 |
|
WikiTools::Table(@rows)); |
5681 |
|
# Now we show the relation's indexes. These are formatted as another |
5682 |
|
# table. |
5683 |
|
@rows = (); |
5684 |
|
# Push in the header row. |
5685 |
|
push @rows, [qw(Index Unique Fields Notes)]; |
5686 |
|
# Get the index hash. |
5687 |
|
my $indexTable = $relationData->{Indexes}; |
5688 |
|
# Loop through the indexes. For an entity, there is always at least one index. |
5689 |
|
# For a relationship, there are at least two. The upshot is we don't need to |
5690 |
|
# worry about accidentally generating a frivolous table here. |
5691 |
|
for my $indexName (sort keys %$indexTable) { |
5692 |
|
my $indexData = $indexTable->{$indexName}; |
5693 |
|
# Determine whether or not the index is unique. |
5694 |
|
my $unique = ((exists $indexData->{Unique} && $indexData->{Unique} eq "true") ? |
5695 |
|
"yes" : ""); |
5696 |
|
# Get the field list. |
5697 |
|
my $fields = join(', ', @{$indexData->{IndexFields}}); |
5698 |
|
# Get the note text. |
5699 |
|
my $description = ""; |
5700 |
|
if (my $note = $indexData->{Notes}) { |
5701 |
|
$description = WikiNote($note->{content}); |
5702 |
|
} |
5703 |
|
# Format this row. |
5704 |
|
my @row = ($indexName, $unique, $fields, $description); |
5705 |
|
push @rows, \@row; |
5706 |
|
} |
5707 |
|
# Add the index list to the result. |
5708 |
|
$retVal .= "\n\n" . WikiTools::Table(@rows); |
5709 |
|
} |
5710 |
|
|
5711 |
=head3 _ShowRelationTable |
=head3 _ShowRelationTable |
5712 |
|
|
5713 |
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 |
5758 |
$htmlString .= "<li><b>Index $fullName</b>\n<ul>\n"; |
$htmlString .= "<li><b>Index $fullName</b>\n<ul>\n"; |
5759 |
# Add any note text. |
# Add any note text. |
5760 |
if (my $note = $indexData->{Notes}) { |
if (my $note = $indexData->{Notes}) { |
5761 |
$htmlString .= "<li>" . _HTMLNote($note->{content}) . "</li>\n"; |
$htmlString .= "<li>" . HTMLNote($note->{content}) . "</li>\n"; |
5762 |
} |
} |
5763 |
# Add the fiield list. |
# Add the fiield list. |
5764 |
$htmlString .= "<li><i>" . join(', ', @{$indexData->{IndexFields}}) . "</i></li>\n"; |
$htmlString .= "<li><i>" . join(', ', @{$indexData->{IndexFields}}) . "</i></li>\n"; |
5824 |
# Compute the number of columns. |
# Compute the number of columns. |
5825 |
my $colCount = @colNames; |
my $colCount = @colNames; |
5826 |
# Generate the title row. |
# Generate the title row. |
5827 |
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"; |
5828 |
# Loop through the columns, adding the column header rows. |
# Loop through the columns, adding the column header rows. |
5829 |
$htmlString .= "<tr>"; |
$htmlString .= "<tr>"; |
5830 |
for my $colName (@colNames) { |
for my $colName (@colNames) { |
5843 |
=cut |
=cut |
5844 |
|
|
5845 |
sub _CloseTable { |
sub _CloseTable { |
5846 |
return "</table></p>\n"; |
return "</table>\n"; |
5847 |
} |
} |
5848 |
|
|
5849 |
=head3 _ShowField |
=head3 _ShowField |
5873 |
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>"; |
5874 |
# If we have content, add it as a third column. |
# If we have content, add it as a third column. |
5875 |
if (exists $fieldData->{Notes}) { |
if (exists $fieldData->{Notes}) { |
5876 |
$htmlString .= "<td>" . _HTMLNote($fieldData->{Notes}->{content}) . "</td>"; |
$htmlString .= "<td>" . HTMLNote($fieldData->{Notes}->{content}) . "</td>"; |
5877 |
} |
} |
5878 |
# Close off the row. |
# Close off the row. |
5879 |
$htmlString .= "</tr>\n"; |
$htmlString .= "</tr>\n"; |
5881 |
return $htmlString; |
return $htmlString; |
5882 |
} |
} |
5883 |
|
|
5884 |
=head3 _HTMLNote |
=head3 _ObjectNotes |
|
|
|
|
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 |
|
5885 |
|
|
5886 |
C<< my $string = StringGen($pattern1, $pattern2, ... $patternN); >> |
my @noteParagraphs = _ObjectNotes($objectData); |
5887 |
|
|
5888 |
Returns a random string derived from a randomly-chosen format pattern. The pattern |
Return a list of the notes and asides for an entity or relationship in |
5889 |
can either be a number (indicating the number of characters desired, or the letter |
Wiki format. |
|
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. |
|
5890 |
|
|
5891 |
=over 4 |
=over 4 |
5892 |
|
|
5893 |
=item pattern1, pattern2, ... patternN |
=item objectData |
5894 |
|
|
5895 |
List of patterns to be used to generate string values. |
The metadata for the desired entity or relationship. |
5896 |
|
|
5897 |
=item RETURN |
=item RETURN |
5898 |
|
|
5899 |
A single string generated from a pattern. |
Returns a list of text paragraphs in Wiki markup form. |
5900 |
|
|
5901 |
=back |
=back |
5902 |
|
|
5903 |
=cut |
=cut |
5904 |
|
|
5905 |
sub StringGen { |
sub _ObjectNotes { |
5906 |
# Get the parameters. |
# Get the parameters. |
5907 |
my @patterns = @_; |
my ($objectData) = @_; |
|
# Choose the appropriate pattern. |
|
|
my $chosenPattern = RandParam(@patterns); |
|
5908 |
# Declare the return variable. |
# Declare the return variable. |
5909 |
my $retVal = ""; |
my @retVal; |
5910 |
# Determine whether this is a count or a picture pattern. |
# Loop through the types of notes. |
5911 |
if ($chosenPattern =~ m/^\d+/) { |
for my $noteType (qw(Notes Asides)) { |
5912 |
# Here we have a count. Get the string of source characters. |
my $text = $objectData->{$noteType}; |
5913 |
my $letterString = $PictureTable{'X'}; |
if ($text) { |
5914 |
my $stringLen = length $letterString; |
push @retVal, "", WikiNote($text->{content}); |
|
# 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; |
|
5915 |
} |
} |
|
# Return the string formed. |
|
|
return $retVal; |
|
5916 |
} |
} |
|
|
|
|
=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; |
|
5917 |
# Return the result. |
# 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. |
|
5918 |
return @retVal; |
return @retVal; |
5919 |
} |
} |
5920 |
|
|