summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm')
-rw-r--r--Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm770
1 files changed, 0 insertions, 770 deletions
diff --git a/Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm b/Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm
deleted file mode 100644
index 53673e37dc8..00000000000
--- a/Master/texmf-dist/source/latex/stex/bin/rng2dot/ModelRNC.pm
+++ /dev/null
@@ -1,770 +0,0 @@
-# anything that starts with # is removed until \n (considered as a comment)
-# except in literals;
-#
-# NCName is limited to a-zA-Z0-9.-_
-#
-# no proper support for except nameClass
-# no support for exceptPatterns
-
-package ModelRNC;
-
-use strict;
-use File::Basename;
-
-my $DOCUMENT = '_Document_';
-
-sub new{
- my ($class) = @_;
- my $self = {};
- $self->{literalCount} = 0;
- bless($self, $class);
-}
-
-# this is the main method of the package
-# it should be called right after new
-sub process{
- my ($self, $filename) = @_;
- $self->readfile($filename);
- $self->clean_rnc;
- $self->read_topLevel;
- $self->build_info;
- # free some memory
- $self->{DATA} = ''; $self->{FILEPATH} = ''; $self->{GRAPH} = '';
-}
-
-sub Error{
- my ($self, $msg) = @_;
- print "'$self->{DATA}'\n";
- die $msg."\n";
-}
-
-# read a file into $storage;
-# or $self->{DATA} if $storage not given
-sub readfile{
- my ($self, $filename, $storage) = @_;
-
- # NOTE: this is not exactly perfect
- if ($self->{FILEPATH}){
- $filename = $self->{FILEPATH}.$filename unless -e $filename; }
- my $basepath = dirname($filename);
- $basepath .= '/' if ($basepath && $basepath !~ m|/$|);
- $self->{FILEPATH} = $basepath;
-
- open(FIN, $filename) or $self->Error("Cout not open '$filename'");
- my @data = <FIN>;
- close(FIN);
-
- # for use in namespace set selection
- push(@{$self->{LOADEDFILES}}, $filename);
-
- if (defined $storage){ $$storage = join('',@data); }
- else { $self->{DATA} = join('',@data); }
-}
-
-# remove lines after ##
-sub remove_annotations{
- my ($self, $data) = @_;
- $data = \$self->{DATA} unless $data;
- do {} while ($$data =~ s/\[[^\]\[]*\]//g);
- $$data =~ s/\#\#[^\n]*//g;
-}
-
-# remove all lines that start with # except
-# the ones that start with ##
-sub remove_comments{
- my ($self, $data) =@_;
- $data = \$self->{DATA} unless $data;
- $$data =~ s/\#[^\#\n][^\n]*//g;
- $$data =~ s/\#\n/\n/g;
-}
-
-sub scan_literals{
- my ($self, $data) = @_;
- my @litseg; my $seg = 0;
- $data = \$self->{DATA} unless $data;
- while ($$data =~ s/\"\"\"((\"{0,2}[^\"])*)\"\"\"/_LITSEG$seg/) { $litseg[$seg++] = $1; }
- while ($$data =~ s/\'\'\'((\'{0,2}[^\'])*)\'\'\'/_LITSEG$seg/) { $litseg[$seg++] = $1; }
- while ($$data =~ s/\"([^\"\n]*)\"/_LITSEG$seg/) { $litseg[$seg++] = $1; }
- while ($$data =~ s/\'([^\'\n]*)\'/_LITSEG$seg/) { $litseg[$seg++] = $1; }
-
- while ($$data =~ s/_LITSEG(\d+)\s*~\s*_LITSEG(\d+)/_LITSEG$seg/)
- { $litseg[$seg++] = $litseg[$1].$litseg[$2]; }
-
- while ($$data =~ s/_LITSEG(\d+)/!LIT$self->{literalCount}/)
- { $self->{literals}[$self->{literalCount}++] = $litseg[$1]; }
-}
-
-# remove \x{N} sections
-sub special_chars{
- my ($self, $data) = @_;
- $data = \$self->{DATA} unless $data;
- while ($$data =~ m/\\x\{([a-fA-F0-9x]+)\}/g){
- my $lng = length($&); my $p = pos($$data) - $lng;
- substr($$data, $p, $lng) = chr(hex($1));
- pos($$data) = $p + 1;
- }
-}
-
-# remove redundant data from loaded file
-sub clean_rnc{
- my ($self, $data) = @_;
- $data = \$self->{DATA} unless $data;
- $self->scan_literals($data);
- $self->special_chars($data);
- $self->remove_annotations($data);
- $self->remove_comments($data);
- # add a newline, just in case the last word is a keyword
- # and for nice printing;
- $$data.="\n";
-}
-
-# in the processing of the data, the data is destroyed
-# provide two methods for resolving that
-sub backup{
- my ($self) = @_;
- $self->{BACKUP_DATA} = $self->{DATA};
-}
-
-sub restore{
- my ($self) = @_;
- $self->{DATA} = $self->{BACKUP_DATA} if defined $self->{BACKUP_DATA};
-}
-
-# set or retrieve stored data
-sub data{
- my ($self, $newdata) = @_;
- if (defined $newdata){ $self->{DATA} = $newdata; }
- else { return $self->{DATA}; }
-}
-
-# put back some extracted string from DATA
-sub put_back{
- my ($self, $back) = @_;
- substr($self->{DATA}, 0, 0) = $back;
-}
-
-# try to match a keyword; return 1 on success; 0 on failure
-# NOTE: this implies that the used keywords should be followed by
-# some non alphanumeric or space character
-sub read_keyword{
- my ($self, $keyword) = @_;
- return 0 if ($self->{DATA} !~ /^\s*\Q$keyword\E\s*[^a-zA-Z0-9_\-\.]/);
- substr($self->{DATA}, 0, length($&)-1) = '';
- return 1;
-}
-
-# same as read_keyword, except it dies not expect a non-word character
-# after the word it searches
-sub read_controlword{
- my ($self, $controlword) = @_;
- return 0 if ($self->{DATA} !~ /^\s*\Q$controlword\E\s*/);
- substr($self->{DATA},0,length($&)) = '';
- return 1;
-}
-
-# expect a keyword; if the word is found, it is extracted
-# otherwise, the program dies (the grammar is incorrect)
-sub expect_keyword{
- my ($self, $keyword) = @_;
- $self->Error("Expected keyword '$keyword' was not found")
- if ($self->{DATA} !~ /^\s*\Q$keyword\E\s*/);
- substr($self->{DATA}, 0, length($&)) = '';
-}
-
-
-# Does not include Extender and CombiningChar
-# (as in XML Namespaces: http://www.w3.org/TR/REC-xml/)
-sub read_NCName{
- my ($self, $terminators) = @_;
- my $termin_exists = 1;
- if (defined $terminators) { $terminators = "[$terminators]"; }
- else { $terminators = ''; $termin_exists = 0; }
- if ($self->{DATA} =~ /^\s*([_a-zA-Z][_a-zA-Z0-9\.\-]*)\s*$terminators/){
- substr($self->{DATA}, 0, length($&)-$termin_exists) = '';
- return $1;
- }
- return undef;
-}
-
-# try to match an identifierOrKeyword; return it in case
-# of success; return undef in case of failure;
-sub read_identifierOrKeyword{
- my ($self, $terminators) = @_;
- $self->read_controlword('\\');
- return $self->read_NCName($terminators);
-}
-
-# see if the argument is in the set of defined keyword of RelaxNG
-sub isRNCKeyword{
- my ($word) = @_;
- return ($word =~ /^\s*(attribute|default|datatypes|div|element|empty|external|grammar|include|inherit|list|mixed|namespace|notAllowed|parent|start|string|text|token)\s*$/);
-}
-
-# read an identifier; return undef if no identifier can be read
-sub read_identifier{
- my ($self, $terminators) = @_;
- my $quote = $self->read_controlword('\\');
- my $ident = $self->read_NCName($terminators);
- if (!$quote && $ident && isRNCKeyword($ident)){
- $self->put_back($ident);
- return undef;
- }
- return $ident;
-}
-
-# read a literal in any form given;
-# segments are taken into account
-sub read_literal{
- my ($self) = @_;
- if ($self->{DATA} =~ /^\s*!LIT(\d+)\s*/){
- substr($self->{DATA}, 0, length($&)) = '';
- return $self->{literals}[$1];
- }
- return undef;
-}
-
-# read a namespace URI literal
-sub read_namespaceURILiteral{
- my ($self, $inherited_namespace) = @_;
- return $inherited_namespace if $self->read_keyword('inherit');
- return $self->read_literal;
-}
-
-# read any URI literal
-sub read_anyURILiteral{
- my ($self) = @_;
- $self->read_literal; }
-
-sub getNS{
- my ($self, $nspref) = @_;
- $self->{${$self->{LOADEDFILES}}[$#{$self->{LOADEDFILES}}]}->{NAMESPACE}{$nspref}; }
-
-sub setNS{
- my ($self, $nspref, $nsval) = @_;
- $self->{${$self->{LOADEDFILES}}[$#{$self->{LOADEDFILES}}]}->{NAMESPACE}{$nspref} = $nsval; }
-
-# read all declarations, until none can be read
-sub read_decl{
- my ($self, $inherited_namespace) = @_;
- $inherited_namespace = '' unless defined $inherited_namespace;
- $self->setNS('default',$inherited_namespace) unless $self->getNS('default');
- my $found = 1;
- while ($found){
- if ($self->read_keyword('namespace')){
- my $namespace_name = $self->read_identifierOrKeyword('=');
- $self->Error('Undefined namespace name') unless $namespace_name;
- $self->expect_keyword('=');
- my $namespace_value =
- $self->read_namespaceURILiteral($inherited_namespace);
- $self->Error('Undefined namespace URI')
- unless defined $namespace_value;
- $self->setNS($namespace_name, $namespace_value);
- }
- elsif ($self->read_keyword('default') &&
- $self->read_keyword('namespace')){
- my $namespace_name = undef;
- if (!$self->read_controlword('=')){
- $namespace_name = $self->read_identifierOrKeyword('=');
- $self->Error('Undefined namespace name')
- unless $namespace_name;
- $self->expect_keyword('=');
- }
- my $namespace_value =
- $self->read_namespaceURILiteral($inherited_namespace);
- $self->Error('Undefined namespace URI')
- unless defined $namespace_value;
- $self->setNS('default', $namespace_value);
- $self->setNS($namespace_name, $namespace_value)
- if $namespace_name;
- }
- elsif ($self->read_keyword('datatypes')){
- my $datatype_name = $self->read_identifierOrKeyword('=');
- $self->Error('Undefined datatype name') unless $datatype_name;
- $self->expect_keyword('=');
- my $datatype_value = $self->read_literal;
- $self->Error('Undefined datatype value')
- unless defined $datatype_value;
- }
- else { $found = 0; }
- }
-}
-
-# ignore an annotation definition;
-# (assumes annotation content does not exist)
-# (it has been removed by clean_rnc)
-sub ignore_annotation{
- my ($self) = @_;
- $self->read_CName; }
-
-# read a name (CName) of the form NCName:NCName
-sub read_CName{
- my ($self, $terminators) = @_;
- $terminators = '\s' unless defined $terminators;
- my $name = $self->read_NCName(':');
- if ($name){
- $self->expect_keyword(':');
- my $part2 = $self->read_NCName($terminators);
- $self->Error('Incomplete CName definition') unless $part2;
- $name .= ":$part2";
- }
- return $name;
-}
-
-# read a datatype name
-sub read_datatypeName{
- my ($self, $terminators) = @_;
- $terminators = '\s' unless defined $terminators;
- if ($self->{DATA} =~ /^\s*string\s*[$terminators]/){
- substr($self->{DATA},0,length($&)-1) = '';
- return 'string';
- }
- elsif ($self->{DATA} =~ /^\s*token\s*[$terminators]/){
- substr($self->{DATA},0,length($&)-1) = '';
- return 'token';
- } else {
- return $self->read_CName($terminators);
- }
-}
-
-# read a datatype value
-sub read_datatypeValue{
- my ($self) = @_;
- return $self->read_literal;
-}
-
-# return the set of names an element or an attribute can have
-# this does not work well on complicated name classes
-sub read_nameClassEx{
- my ($self, $terminators) = @_;
-
- my @result;
-
- if ($self->read_controlword('(')){
- @result = $self->read_nameClassEx($terminators.'\)');
- $self->expect_keyword(')');
- } else {
-
- #anyName
- if ($self->read_controlword('*')){
- push(@result, '*');
- if ($self->read_controlword('-')){
- print STDERR "Warning: USE OF EXCEPT NAMECLASS NOT IMPLEMENTED\n";
- push(@result, $self->read_nameClassEx($terminators));
- }
- }
- # nsName or name(CName)
- elsif (my $part1 = $self->read_NCName(':')){
- $self->expect_keyword(':');
- if ($self->read_controlword('*')){
- push(@result, "$part1:*");
- if ($self->read_controlword('-')){
- print STDERR
- "Warning: USE OF EXCEPT NAMECLASS NOT IMPLEMENTED\n";
- push(@result, '-',
- $self->read_nameClassEx($terminators));
- }
- } else {
- push(@result, $part1.':'.$self->read_NCName($terminators.'\|'));
- }
- }
- # name(identifierOrKeyword)
- else {
- my $name = $self->read_identifierOrKeyword($terminators.'\|');
- $self->Error('Incomplete name class given') unless $name;
- push(@result, $name);
- }
- }
-
- $self->Error('No name class provided') unless @result;
-
- # see if we have more possible names:
- push(@result, $self->read_nameClassEx($terminators))
- if ($self->read_controlword('|'));
-
- return @result;
-}
-
-sub read_nameClass{
- my ($self, $terminators, @parents) = @_;
- $terminators = '\s' unless defined $terminators;
- my @result = $self->read_nameClassEx($terminators);
- my @finalRes;
-
- if (@parents && @result){
-
- my @nsList, my %saw = ();
- foreach (@parents){
- if (/\{(.*)\}:.+/){
- next if $saw{$1};
- push(@nsList, $1); $saw{$1} = 1; }
- else {
- next if $saw{'default'};
- push(@nsList, $self->getNS('default')); $saw{'default'} = 1; }
- }
-
- foreach my $res(@result){
- if ($res =~ /(.+):(.+)/){
- push(@finalRes, $self->ns_prepend($2, $1)); }
- else {
- map(push(@finalRes, "{$_}:$res"), @nsList); }
- }
- } else {
- map(push(@finalRes, (/(.+):(.+)/)?
- $self->ns_prepend($2, $1):$self->ns_prepend($_)), @result);
- }
- return @finalRes;
-}
-
-
-# read a parameter declaration, if one exists
-sub read_param{
- my ($self) = @_;
- my $id = $self->read_identifierOrKeyword('=');
- return (undef, undef) unless $id;
- $self->expect_keyword('=');
- my $val = $self->read_literal;
- $self->Error('No parameter value specified') unless defined $val;
- return ($id, $val);
-}
-
-sub begin_read_newfile{
- my ($self) = @_;
- my $file = $self->read_anyURILiteral;
- my $inherit = 'default';
- if ($self->read_keyword('inherit')){
- $self->expect_keyword('=');
- $inherit = $self->read_identifierOrKeyword; }
- $inherit = $self->getNS($inherit);
- my $newdata = '';
- $self->readfile($file, \$newdata);
- $self->clean_rnc(\$newdata);
- $self->put_back($newdata.'#');
- $self->read_decl($inherit); }
-
-sub end_read_newfile{
- my ($self) = @_;
- pop(@{$self->{LOADEDFILES}});
- $self->expect_keyword('#'); }
-
-# read a pattern
-sub read_pattern{
- my ($self, $grammarPath, $grammarIdent, @parentElements) = @_;
- my $found = 1; my $grammarCount = 0;
- my $DEF = $grammarPath.':'.$grammarIdent;
-
- if ($self->read_keyword('element')){
- my @elementNames = $self->read_nameClass('{', @parentElements);
- $self->Error('Unspecified element name') unless @elementNames;
- map(push(@{$self->{GRAPH}->{$DEF}->{$_}{ELEMENTS}},
- @elementNames), @parentElements);
- $self->expect_keyword('{');
- $self->read_pattern($grammarPath, $grammarIdent, @elementNames);
- $self->expect_keyword('}');
- }
- elsif ($self->read_keyword('attribute')){
- my @attributeNames = $self->read_nameClass('{');
- $self->Error('Unspecified attribute name') unless @attributeNames;
- map(push(@{$self->{GRAPH}->{$DEF}->{$_}{ATTRIBUTES}},
- @attributeNames), @parentElements);
- $self->expect_keyword('{');
- $self->read_pattern($grammarPath, $grammarIdent, @parentElements);
- $self->expect_keyword('}');
- }
- elsif ($self->read_keyword('list') || $self->read_keyword('mixed')){
- $self->expect_keyword('{');
- $self->read_pattern($grammarPath, $grammarIdent, @parentElements);
- $self->expect_keyword('}');
- }
- elsif ($self->read_controlword('(')){
- $self->read_pattern($grammarPath, $grammarIdent, @parentElements);
- $self->expect_keyword(')');
- }
- elsif (my $datatypeValue =
- $self->read_datatypeValue){
- # do nothing
- }
- elsif (my $datatypeName =
- $self->read_datatypeName('\s\{\}\-!')){
- my $datatypeValue = $self->read_datatypeValue;
-
- # read parameters; ignore them for now
- if ($self->read_controlword('{')){
- my ($ident, $val);
- do{
- ($ident, $val) = $self->read_param;
- } while ($ident && $val);
- $self->expect_keyword('}');
- }
- # read possible exceptPattern
- if ($self->read_controlword('-')){
- print STDERR "Warning: USE OF EXCEPT PATTERN NOT IMPLEMENTED\n";
- $self->Error('exceptPattern expected but not found')
- unless $self->read_pattern($grammarPath, $grammarIdent,
- @parentElements);
- }
- }
- elsif ($self->read_keyword('external')){
- $self->begin_read_newfile;
- $self->read_pattern($grammarPath, $grammarIdent, @parentElements);
- $self->end_read_newfile;
- }
- elsif ($self->read_keyword('grammar')){
- my $ident = $DEF.$grammarCount++;
- $self->expect_keyword('{');
- $self->read_grammarContent($ident, @parentElements);
- $ident .= ':start';
- map(push(@{$self->{GRAPH}->{$DEF}->{$_}{REFS}},
- $ident), @parentElements);
- $self->expect_keyword('}');
- }
- elsif ($self->read_keyword('parent')){
- my $ident = $self->read_identifier;
- if ($grammarPath =~ /^([.]+:)[^:]+$/){
- $ident = $1.$ident;
- map(push(@{$self->{GRAPH}->{$DEF}->{$_}{REFS}},
- $ident), @parentElements);
- }
- }
- elsif ($self->read_keyword('empty') || $self->read_keyword('text')
- || $self->read_keyword('notAllowed')){
- # do nothing
- }
- elsif (my $ident = $self->read_identifier){
- # check if we did not enter a grammar by mistake:
- my $asg = $self->read_assignMethod(1);
- if ($ident && $asg){
- $self->put_back($ident.$asg);
- } else {
- $ident = $grammarPath.':'.$ident;
- map(push(@{$self->{GRAPH}->{$DEF}->{$_}{REFS}},
- $ident), @parentElements);
- }
-
- } else { $found = 0; }
-
- if ($self->read_controlword('?') || $self->read_controlword('*')
- || $self->read_controlword('+')){
- # ignore
- }
-
- if ($self->read_controlword(',') || $self->read_controlword('|')
- || $self->read_controlword('&')){
- Error('Pattern expected') unless
- $self->read_pattern($grammarPath, $grammarIdent, @parentElements);
- }
-
- return $found;
-}
-
-sub read_assignMethod{
- my ($self, $asString) = @_;
- if ($asString){
- return '&=' if ($self->read_controlword('&='));
- return '|=' if ($self->read_controlword('|='));
- return '=' if ($self->read_controlword('='));
- return undef;
- }
- return 3 if ($self->read_controlword('&='));
- return 2 if ($self->read_controlword('|='));
- return 1 if ($self->read_controlword('='));
- return 0;
-}
-
-# read a grammar pattern
-sub read_grammarPattern{
- my ($self, $DEF, @parentElements) = @_;
- if ($self->read_keyword('grammar')){
- $self->expect_keyword('{');
- $self->read_grammarContent($DEF, @parentElements);
- $self->expect_keyword('}'); }
- else{
- $self->read_grammarContent($DEF, @parentElements);}
-}
-
-# read all possible grammar contents
-sub read_grammarContent{
- my ($self, $DEF, @parentElements) = @_;
- my ($div, $found) = (0, 1);
-
- while ($found){
- if ($self->read_keyword('div')){
- $div++;
- $self->expect_keyword('{');
- $self->read_grammarContent($DEF.':_G'.$div, @parentElements);
- $self->expect_keyword('}');
- }
- elsif ($self->read_keyword('include')){
- $self->begin_read_newfile;
- $self->read_grammarPattern($DEF, @parentElements);
- $self->end_read_newfile;
- if ($self->read_controlword('{')){
- $self->read_grammarContent($DEF, @parentElements);
- $self->expect_keyword('}'); }
- }
- elsif ($self->read_keyword('start')){
- my $asg = $self->read_assignMethod;
- $self->Error('Invalid assign method') unless $asg;
- @{$self->{GRAPH}->{$DEF.':start'}->{PARENTS}} = @parentElements;
- $self->read_pattern($DEF, 'start', @parentElements);
- }
- elsif (my $ident = $self->read_identifier('=\|\&')){
- my $asg = $self->read_assignMethod;
- $self->Error('Invalid assign method') unless $asg;
- my $ref = $DEF.':'.$ident;
- %{$self->{GRAPH}->{$ref}} = () if $asg == 1;
- @{$self->{GRAPH}->{$ref}->{PARENTS}} = @parentElements;
- $self->read_pattern($DEF, $ident, @parentElements);
- }
- elsif ($self->ignore_annotation) {}
- else { $found = 0; }
- }
-}
-
-sub ns_prepend{
- my ($self, $tag, $ns_pref) = @_;
- my $ns = $ns_pref?$self->getNS($ns_pref):undef;
- $ns = $self->getNS('default') unless $ns;
- return "{$ns}:$tag";
-}
-
-# this should match the whole file
-sub read_topLevel{
- my ($self) = @_;
- $self->read_decl;
- $self->read_pattern($DOCUMENT, 'start', $DOCUMENT);
-
- my ($after, $before) = (0, 1);
- while ($before != $after){
- $before = length($self->{DATA});
- $self->read_grammarContent($DOCUMENT, $DOCUMENT);
- $after = length($self->{DATA});
- }
- $self->{DATA} = trim($self->{DATA});
- $self->Error('Unable to completely process data')
- unless $self->{DATA} eq '';
-}
-
-# remove leading and trailing white space
-sub trim{
- my ($arg) = @_;
- $arg =~ s/^\s+//;
- $arg =~ s/\s+$//;
- return $arg;
-}
-
-sub build_info{
- my ($self) = @_;
-
- my %seen = ();
- local *go = sub {
- my ($reference, $node) = @_;
-
- my $ident = $reference.'#'.$node;
- return if defined $seen{$ident};
- $seen{$ident} = 1;
-
- map($self->{ATTR}->{$node}{$_} = 1,
- @{$self->{GRAPH}->{$reference}->{$node}{ATTRIBUTES}})
- if defined $self->{GRAPH}->{$reference}->{$node}{ATTRIBUTES};
-
- my @sons;
- map(push(@sons, ($reference, $_)),
- @{$self->{GRAPH}->{$reference}->{$node}{ELEMENTS}})
- if defined $self->{GRAPH}->{$reference}->{$node}{ELEMENTS};
-
- if (defined $self->{GRAPH}->{$reference}->{$node}{REFS}){
- my @refs = @{$self->{GRAPH}->{$reference}->{$node}{REFS}};
- foreach my $ref(@refs){
- next unless $self->{GRAPH}->{$ref}->{PARENTS};
- foreach my $son(@{$self->{GRAPH}->{$ref}->{PARENTS}}){
- map(push(@sons, ($ref, $_)),
- @{$self->{GRAPH}->{$ref}->{$son}{ELEMENTS}})
- if defined $self->{GRAPH}->{$ref}->{$son}{ELEMENTS};
- push(@refs, @{$self->{GRAPH}->{$ref}->{$son}{REFS}})
- if defined $self->{GRAPH}->{$ref}->{$son}{REFS};
- # if a reference has attributes defined,
- # they will appear as attributes to $DOCUMENT
- # if the reference is not defined within some element
- map($self->{ATTR}->{$node}{$_} = 1,
- @{$self->{GRAPH}->{$ref}->{$son}{ATTRIBUTES}})
- if ($self->{GRAPH}->{$ref}->{$son}{ATTRIBUTES} &&
- ($son eq $DOCUMENT));
- }
- }
- }
- my $sonCount = ($#sons+1)/2;
- for (my $i = 0; $i < $sonCount; $i++){
- my ($ref, $son) = ($sons[2*$i], $sons[2*$i+1]);
- go($sons[2*$i], $sons[2*$i+1]);
- $self->{NODES}->{$node}{$son} = 1;
- }
- };
-
- go($DOCUMENT.':start', $DOCUMENT);
-
- %seen = ();
- local *gnodes = sub {
- my ($node) = @_;
- return if $seen{$node};
- $seen{$node} = 1;
- foreach my $son(keys %{$self->{NODES}->{$node}}){
- map($self->{GNODES}->{$node}{$_} = $son,
- keys %{$self->{NODES}->{$son}});
- gnodes($son); }
- };
-
- gnodes($DOCUMENT);
- @{$self->{TAGLIST}} = keys %seen;
-}
-
-sub getTagList {
- my ($self) = @_;
- return @{$self->{TAGLIST}};
-}
-
-sub tagChildren {
- my ($self, $tag) = @_;
- keys %{$self->{NODES}->{$tag}}; }
-
-# given a tag and a childtag, return whether
-# tag can contain childtag
-sub canContain()
-{
- my ($self, $tag, $childtag) = @_;
- return ($self->{NODES}->{$tag}{$childtag} ||
- $self->{NODES}->{$tag}{'*'})?1:0;
-}
-
-# there can be more results: list ?
-# there can be no result, but a class of results.. like a nsName
-# choose representative?
-sub canContainIndirect()
-{
- my ($self, $tag, $childtag) = @_;
- return $self->{GNODES}->{$tag}{$childtag} if
- $self->{GNODES}->{$tag}{$childtag};
-
- if ($self->{NODES}->{$tag}{'*'}){
- foreach (@{$self->{TAGLIST}}){
- return $_ if $self->{NODES}->{$_}{$childtag};
- }
- }
-}
-
-# given a tag and an attribute return whether
-# the tag can have that attribute
-sub canHaveAttribute()
-{
- my ($self, $tag, $attr) = @_;
- return ($self->{ATTR}->{$tag}{$attr} ||
- $self->{ATTR}->{$tag}{'*'})?1:0;
-}
-
-sub canContainSomehow()
-{
- my ($self, $tag, $childtag) = @_;
- return ($self->canContain($tag, $childtag) ||
- $self->canContainIndirect($tag, $childtag));
-}
-
-1;