From: Andreas Neiser Date: Wed, 3 Jul 2013 07:25:08 +0000 (+0200) Subject: Cleaning up xml-db.pl, only --dump works now X-Git-Url: https://jspc29.x-matter.uni-frankfurt.de/git/?a=commitdiff_plain;h=e1ec01c3197f863fe8fd3a471d5d3bc268bd62e2;p=daqtools.git Cleaning up xml-db.pl, only --dump works now --- diff --git a/xml-db/schema/TrbNetSetup.xsd b/xml-db/schema/TrbNetSetup.xsd index 46e76d6..d86a5d9 100644 --- a/xml-db/schema/TrbNetSetup.xsd +++ b/xml-db/schema/TrbNetSetup.xsd @@ -14,6 +14,10 @@ + + + + @@ -47,7 +51,6 @@ - diff --git a/xml-db/xml-db.pl b/xml-db/xml-db.pl index dee7d6f..b51bb81 100755 --- a/xml-db/xml-db.pl +++ b/xml-db/xml-db.pl @@ -3,9 +3,6 @@ use strict; use warnings; use XML::LibXML; -use Storable; -#use XML::LibXML::Debugging; -#use XML::LibXML::Iterator; use Data::TreeDumper; use Getopt::Long; use Pod::Usage; @@ -13,6 +10,7 @@ use File::chdir; use FindBin qw($RealBin); use Data::Dumper; + # some default config options # and provide nice help documentation # some global variables, needed everywhere @@ -23,6 +21,7 @@ my $verbose = 0; my $warnings = 1; my $dir = $RealBin; my $dump_database = 0; +my $force = 0; Getopt::Long::Configure(qw(gnu_getopt)); GetOptions( @@ -31,7 +30,8 @@ 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; @@ -58,155 +58,9 @@ if ($dump_database) { } 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 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 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; @@ -220,14 +74,13 @@ sub PrintMessage($$) { } 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); } } @@ -288,78 +141,50 @@ sub IterateChildren { } - - -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: @@ -367,9 +192,7 @@ xml-db.pl --dump [entity names] -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 @@ -392,7 +215,7 @@ Set the base directory where the default XML files can be found in sub-directori =head1 DESCRIPTION -B provides basic access to the XML database describing -the TRB registers. +B updates the cache directory from the provided XML +files in the database directory. =cut