use warnings;
use XML::LibXML;
-use Storable;
-#use XML::LibXML::Debugging;
-#use XML::LibXML::Iterator;
use Data::TreeDumper;
use Getopt::Long;
use Pod::Usage;
use FindBin qw($RealBin);
use Data::Dumper;
+
# some default config options
# and provide nice help documentation
# some global variables, needed everywhere
my $warnings = 1;
my $dir = $RealBin;
my $dump_database = 0;
+my $force = 0;
Getopt::Long::Configure(qw(gnu_getopt));
GetOptions(
'verbose|v+' => \$verbose,
'warnings|w!' => \$warnings,
'dir=s' => \$dir,
- 'dump' => \$dump_database
+ 'dump' => \$dump_database,
+ 'force|f=s' => \$force
) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-exitval => 0, -verbose => 2) if $man;
}
sub Main {
- # load the unmerged database and the provided files
- my ($db,$files) = &LoadDBAndFiles(@ARGV);
-
-
- # this ref holds all the vital "information". There's a merged
- # TrbNetEntity-based document at
- # $merged->{$trbaddress}->{$base_address}
- my $merged = {};
-
- foreach my $item (@$files) {
- my $file = $item->[0];
- my $doc = $item->[1];
-
- foreach my $trbnode ($doc->getDocumentElement->findnodes('trb')) {
- # Note: we cannot first collect all the <trb> nodes and then
- # work on them as a whole (this would limit the possibilites in
- # a setup file...)
- my $trbaddress = EvaluateTrbNode($db, $trbnode, $merged);
- WorkOnEntities($merged->{$trbaddress});
- }
- }
-}
-
-sub WorkOnEntities($) {
- my $entities = shift;
- # THIS IS NOT FINISHED AT ALL!
-
- # first, we need to expand the repeat/size statements and calculate
- # the "real" register address (but still relative to parent!). we do
- # this on a cloned copy of the document, since each trb node might
- # change this!
- foreach my $e (keys %$entities) {
- my $doc = $entities->{$e}->cloneNode(1);
- print $e,"\n";
- # first expand registers. we replace the node with cloned copies
- foreach my $reg ($doc->findnodes('//register[@repeat]')) {
- my $repeat = $reg->getAttribute('repeat');
- my $address = $reg->getAttribute('address'); # || PrintMessage($reg, 'Fatal Error: Register must have address attribute
- }
- }
-}
-
-sub EvaluateTrbNode($$$) {
- my $db = shift;
- my $trbnode = shift;
- my $merged = shift;
-
- my $trbaddress = $trbnode->getAttribute('address');
- PrintMessage($trbnode, "Evaluating <trb> at 0x$trbaddress") if $verbose;
- foreach my $node ($trbnode->findnodes('entity')) {
- my $ref = $node->getAttribute('ref');
- # check if we know this type
- PrintMessage($node, "Fatal Error: Entity reference $ref not found in database", 1)
- unless defined $db->{$ref};
-
- # use the provided base address for the registers of the entity
- # or the default one from the db
- my $base_address = $node->getAttribute('address') ||
- $db->{$ref}->{'Doc'}->getDocumentElement->getAttribute('address');
- # check if we know already something about that entity at this
- # trbaddress and base_address...then use this, otherwise use the
- # a cloned entity from the database as a starting point
- unless (defined $merged->{$trbaddress} and
- defined $merged->{$trbaddress}->{$base_address}) {
- PrintMessage($node, "Cloning entity from database") if $verbose>1;
- # clone deeply (argument = 1)
- $merged->{$trbaddress}->{$base_address} = $db->{$ref}->{'Doc'}->cloneNode(1);
- }
-
- # define a shortcut for the reference to the full entity (to be further modified!)
- my $entity = $merged->{$trbaddress}->{$base_address};
-
- # now we apply the changes $entitynode (provided by elements
- # like field, register, group, ...) to the "full" TrbNetEntity
- # in $entity
- foreach my $elem ($node->findnodes('*')) {
- # try to find the element in $e specified by its unique name
- # attribute
- MergeElementIntoEntity($entity, $elem)
- }
- # after the merging, we can validate $entity again
- # now having a nice schema really pays off!
- eval { $db->{$ref}->{'Schema'}->validate($entity) };
- if ($@) {
- print $entity->toString(2,1) if $verbose>2;
- PrintMessage($node,
- "Fatal Error: Merged entity is not valid anymore:\n$@",1);
- }
-
- # and we can check some more required fields
- foreach my $n ($entity->findnodes('//field | //register | //memory | //fifo | //group')) {
- if ($n->nodeName eq 'field') {
- PrintMessage($n, 'Fatal Error: "start" attribute is required', 1) unless $n->hasAttribute('start');
- } else {
- PrintMessage($n, 'Fatal Error: "address" attribute is required', 1) unless $n->hasAttribute('address');
- }
- }
- }
-
- # the really relevant information is in the reference $merged,
- # so not returned here
- return $trbaddress;
}
-sub MergeElementIntoEntity($$) {
- # note that merging two XML nodes is not simple and
- # thus not in all cases well-defined
- my $entity = shift;
- my $elem = shift;
-
- my $uniquename = $elem->getAttribute('name');
- my $xpath = sprintf('//%s[@name="%s"]',
- $elem->nodeName,
- $uniquename);
- my $e_node = $entity->findnodes($xpath);
- if ($e_node->size == 0) {
- PrintMessage($elem, "Warning: XPath $xpath not found in database entity, skipping") if $warnings;
- next;
- } elsif ($e_node->size > 1) {
- # this should never happen due to schema restrictions, but
- # check again here...
- PrintMessage($elem, "Fatal Error: XPath $xpath found more than once in entity, i.e. ".
- "$uniquename not unique!", 1);
- }
-
- # now apply the changes to that single node
- $e_node = $e_node->shift;
- PrintMessage($elem, "Merging entity item <$uniquename>") if $verbose;
- PrintMessage($elem, "Before merge:\n".$e_node->toString(2)) if $verbose>2;
-
- # override the attributes (using tied hash functionality, which
- # sometimes does not work when reading?)
- foreach my $attr (keys %$elem) {
- next if $attr eq 'name';
- $e_node->setAttribute($attr, $elem->getAttribute($attr));
- }
-
- # appending all additional elements
- foreach my $subelem ($elem->findnodes('*')) {
- $e_node->appendChild($subelem);
- }
-
- # delete all text node, and add the new text (effectively overriding)
- $e_node->findnodes('text()')->map(sub {$e_node->removeChild($_)});
- $e_node->appendChild(XML::LibXML::Text->new($elem->textContent));
-
- PrintMessage($elem, "After merge:\n".$e_node->toString(2)) if $verbose>2;
-}
sub PrintMessage($$) {
my $node = shift;
}
sub DumpDatabase($) {
- # we ignore all files on cmd line
- my ($db, undef) = &LoadDBAndFiles;
- my %entities = map { $_ => 1 } @ARGV;
+ my %entities = map { $_.'.xml' => 1 } (@ARGV);
my $num = scalar keys %entities;
- foreach my $entity (keys %$db) {
- next if $num>0 and not exists $entities{$entity};
- print "Dumping Entity <$entity>:\n" if $num>1;
- DumpDocument($db->{$entity}->{'Doc'});
+ local $CWD = $db_dir;
+ while(<*.xml>) {
+ next if $num>0 and not defined $entities{$_};
+ my($doc,$name) = LoadXML($_);
+ DumpDocument($doc);
}
}
}
-
-
-sub LoadDBAndFiles {
- my $schemas = {};
- my $db = {};
+BEGIN {
+ # declare the variables $schemas and $parser persistent here
my $parser = XML::LibXML->new(line_numbers => 1);
+ my $schemas = {};
- {
- # change to the schema_dir in the first part
- local $CWD = $schema_dir;
-
-
- # we first load the schemas and parse them
- # so we can validate the XML files
- while (<*.xsd>) {
- $schemas->{$_} = XML::LibXML::Schema->new(location => $_);
- print STDERR "Loaded schema <$_> from database\n" if $verbose>1;
- }
-
- # load the xml files in the database
- # change to the db_dir in the first part
+ sub LoadXML {
+ my $filename = shift;
local $CWD = $db_dir;
- while (<*.xml>) {
- my $doc = $parser->parse_file($_);
- my $schema = ValidateXML($doc, $schemas);
- my $dbname = $doc->getDocumentElement->getAttribute('name');
- die "File <$_>: Entity with name $dbname already exists in database"
- if exists $db->{$dbname};
- $db->{$dbname}->{'Doc'} = $doc;
- $db->{$dbname}->{'Schema'} = $schema;
- print STDERR "Loaded and validated entity <$dbname> from database <$_>\n" if $verbose>1;
- }
+ my $doc = $parser->parse_file($filename);
+ ValidateXML($doc);
+ my $dbname = $doc->getDocumentElement->getAttribute('name');
+ print STDERR "Loaded and validated entity <$dbname> from database <$filename>\n" if $verbose>1;
+ return ($doc, $dbname);
}
- # now, back in the normal working directoy, load and
- # validate the provided files
- my $files = [];
- for (@_) {
- my $doc = $parser->parse_file($_);
- ValidateXML($doc, $schemas);
- push(@$files, [$_, $doc]);
- print STDERR "Loaded and validated <$_>\n" if $verbose>1;
- #print "Encoding: ", $doc->getEncoding, "\n";
+ sub ValidateXML {
+ my $doc = shift;
+ my $xsd_file = $doc->getDocumentElement->getAttribute('xsi:noNamespaceSchemaLocation');
+ # Strip filename from path to select proper schema
+ ($xsd_file) = $xsd_file =~ m%.*/([^/]*)$%;
+ my $schema = LoadSchema($xsd_file);
+ $schema->validate($doc);
}
- return ($db, $files);
-}
-
-sub ValidateXML($$) {
- my $doc = shift;
- my $schemas = shift;
- my $xsd_file = $doc->getDocumentElement->getAttribute('xsi:noNamespaceSchemaLocation');
- # Strip filename from path to select proper schema
- ($xsd_file) = $xsd_file =~ m%.*/([^/]*)$%;
- die "Schema $xsd_file not found to validate <$_>" unless defined $schemas->{$xsd_file};
- $schemas->{$xsd_file}->validate($doc);
- return $schemas->{$xsd_file};
+ sub LoadSchema {
+ my $filename = shift;
+ local $CWD = $schema_dir;
+ unless (defined $schemas->{$filename}) {
+ $schemas->{$filename} = XML::LibXML::Schema->new(location => $filename);
+ print STDERR "Loaded schema <$filename> from database\n" if $verbose>1;
+ }
+ return $schemas->{$filename};
+ }
}
-
-#print $xsd;
-
-
__END__
=head1 NAME
-xml-db.pl - Manipulate the TrbNet descriptively using XML
+xml-db.pl - Create cached data structures from the XML entities
=head1 SYNOPSIS
-xml-db.pl [options] [xml file(s)]
+xml-db.pl
xml-db.pl --dump [entity names]
Options:
-v, --verbose be verbose to STDERR
-w, --warnings print warnings to STDERR
--dir directory that contains database and schema subdirs
- -g, --generate generate config xml file (smart guessing from TrbNet)
- -s, --save save all config fields from TrbNet in xml file
- -l, --restore load config fields into TrbNet from xml file
+ -f, --force update all cache entries, regardless of their timestamp
--dump dump the database as tree, restricted to given entity names
=head1 OPTIONS
=head1 DESCRIPTION
-B<This program> provides basic access to the XML database describing
-the TRB registers.
+B<This program> updates the cache directory from the provided XML
+files in the database directory.
=cut
jspc29 / daqtools.git / commitdiff