sub
new {
my
(
$class
,
%options
) =
@_
;
my
$self
=
bless
{
xpath
=> LaTeXML::Common::XML::XPath->new(),
code_namespace_prefixes
=> {},
code_namespaces
=> {},
doctype_namespaces
=> {},
namespace_errors
=> 0,
%options
},
$class
;
$$self
{xpath}->registerFunction(
'match-font'
, \
&LaTeXML::Common::Font::match_font
);
$self
->registerNamespace(
'xml'
,
$LaTeXML::Common::XML::XML_NS
);
$self
->registerDocumentNamespace(
'xml'
,
$LaTeXML::Common::XML::XML_NS
);
return
$self
; }
sub
setDocType {
my
(
$self
,
$roottag
,
$publicid
,
$systemid
) =
@_
;
$$self
{schemadata} = [
'DTD'
,
$roottag
,
$publicid
,
$systemid
];
return
; }
sub
setRelaxNGSchema {
my
(
$self
,
$schema
) =
@_
;
$$self
{schemadata} = [
'RelaxNG'
,
$schema
];
return
; }
sub
loadSchema {
my
(
$self
) =
@_
;
return
$$self
{schema}
if
$$self
{schema_loaded};
my
$name
;
if
(!
$$self
{schemadata}) {
Warn(
'expected'
,
'<model>'
,
undef
,
"No Schema Model has been declared; assuming LaTeXML"
);
$self
->setRelaxNGSchema(
"LaTeXML"
);
$self
->registerNamespace(
ltx
=>
$LTX_NAMESPACE
);
$$self
{permissive} = 1; }
my
(
$type
,
@data
) = @{
$$self
{schemadata} };
if
(
$type
eq
'DTD'
) {
my
(
$roottag
,
$publicid
,
$systemid
) =
@data
;
$name
=
$systemid
;
$$self
{schema} = LaTeXML::Common::Model::DTD->new(
$self
,
$roottag
,
$publicid
,
$systemid
); }
elsif
(
$type
eq
'RelaxNG'
) {
(
$name
) =
@data
;
$$self
{schema} = LaTeXML::Common::Model::RelaxNG->new(
$self
,
$name
); }
if
(
my
$compiled
= !
$$self
{no_compiled}
&& pathname_find(
$name
,
paths
=>
$STATE
->lookupValue(
'SEARCHPATHS'
),
types
=> [
'model'
],
installation_subdir
=>
"resources/$type"
)) {
$self
->loadCompiledSchema(
$compiled
); }
else
{
$$self
{schema}->loadSchema; }
$self
->loadInternalExtensions;
$self
->describeModel
if
$LaTeXML::Common::Model::DEBUG
;
$$self
{schema_loaded} = 1;
return
$$self
{schema}; }
sub
addSchemaDeclaration {
my
(
$self
,
$document
,
$tag
) =
@_
;
$$self
{schema}->addSchemaDeclaration(
$document
,
$tag
);
return
; }
sub
loadInternalExtensions {
my
(
$self
) =
@_
;
if
(!
exists
$$self
{tagprop}{
'ltx:_CaptureBlock_'
}) {
$self
->synthesizeElement(
'ltx:_CaptureBlock_'
,
qw(ltx:block ltx:logical-block ltx:sectional-block Caption)
);
$$self
{tagprop}{
'ltx:_CaptureBlock_'
}{model}{
'svg:g'
} = 1;
$$self
{tagprop}{
'ltx:_CaptureBlock_'
}{model}{
'svg:foreignObject'
} = 1;
}
return
; }
sub
synthesizeElement {
my
(
$self
,
$tag
,
@others
) =
@_
;
$$self
{tagprop}{
$tag
} = {}
unless
$$self
{tagprop}{
$tag
};
my
$capture
=
$$self
{tagprop}{
$tag
};
foreach
my
$other
(
@others
) {
if
(
my
$content
=
$$self
{schemaclass}{
$other
}) {
foreach
my
$child
(
keys
%$content
) {
$$capture
{model}{
$child
} =
$$content
{
$child
}; } }
elsif
(
my
$entry
=
$$self
{tagprop}{
$other
}) {
foreach
my
$child
(
keys
%{
$$entry
{model} }) {
$$capture
{model}{
$child
} =
$$entry
{model}{
$child
}; }
foreach
my
$attr
(
keys
%{
$$entry
{attributes} }) {
$$capture
{attributes}{
$attr
} =
$$entry
{attributes}{
$attr
}; } } }
return
; }
sub
compileSchema {
my
(
$self
) =
@_
;
$$self
{no_compiled} = 1;
$self
->loadSchema;
foreach
my
$prefix
(
sort
keys
%{
$$self
{document_namespaces} }) {
print
$prefix
.
'='
.
$$self
{document_namespaces}{
$prefix
} .
"\n"
; }
if
(
my
$defs
=
$$self
{schemaclass}) {
foreach
my
$classname
(
sort
keys
%$defs
) {
print
$classname
.
':=('
.
join
(
','
,
sort
keys
%{
$$self
{schemaclass}{
$classname
} }) .
')'
.
"\n"
; } }
foreach
my
$tag
(
sort
keys
%{
$$self
{tagprop} }) {
next
if
$tag
=~ /^!/;
print
$tag
.
'{'
.
join
(
','
,
sort
keys
%{
$$self
{tagprop}{
$tag
}{attributes} }) .
'}'
.
'('
.
join
(
','
,
sort
keys
%{
$$self
{tagprop}{
$tag
}{model} }) .
')'
.
"\n"
; }
return
; }
sub
loadCompiledSchema {
my
(
$self
,
$file
) =
@_
;
ProgressSpinup(
"Loading compiled schema $file"
);
my
$MODEL
;
open
(
$MODEL
,
'<'
,
$file
) or Fatal(
'I/O'
,
$file
,
undef
,
"Cannot open Compiled Model $file for reading"
, $!);
my
$line
;
while
(
$line
= <
$MODEL
>) {
if
(
$line
=~ /^([^\{]+)\{(.*?)\}\((.*?)\)$/) {
my
(
$tag
,
$attr
,
$children
) = ($1, $2, $3);
$self
->addTagAttribute(
$tag
,
split
(/,/,
$attr
));
$self
->addTagContent(
$tag
,
split
(/,/,
$children
)); }
elsif
(
$line
=~ /^([^:=]+):=\(?([^)]*?)\)?$/) {
my
(
$classname
,
$elements
) = ($1, $2);
$self
->setSchemaClass(
$classname
, {
map
{ (
$_
=> 1) }
split
(/,/,
$elements
) }); }
elsif
(
$line
=~ /^([^=]+)=(.*?)$/) {
my
(
$prefix
,
$namespace
) = ($1, $2);
$self
->registerDocumentNamespace(
$prefix
,
$namespace
); }
else
{
Fatal(
'internal'
,
$file
,
undef
,
"Compiled model '$file' is malformatted at \"$line\""
); }
}
close
(
$MODEL
);
ProgressSpindown(
"Loading compiled schema $file"
);
return
; }
sub
registerNamespace {
my
(
$self
,
$codeprefix
,
$namespace
) =
@_
;
if
(
$namespace
) {
$$self
{code_namespace_prefixes}{
$namespace
} =
$codeprefix
;
$$self
{code_namespaces}{
$codeprefix
} =
$namespace
;
$$self
{xpath}->registerNS(
$codeprefix
,
$namespace
); }
else
{
my
$prev
=
$$self
{code_namespaces}{
$codeprefix
};
delete
$$self
{code_namespace_prefixes}{
$prev
}
if
$prev
;
delete
$$self
{code_namespaces}{
$codeprefix
}; }
return
; }
sub
getNamespacePrefix {
my
(
$self
,
$namespace
,
$forattribute
,
$probe
) =
@_
;
if
(
$namespace
) {
my
$codeprefix
=
$$self
{code_namespace_prefixes}{
$namespace
};
if
((!
defined
$codeprefix
) && !
$probe
) {
my
$docprefix
=
$$self
{document_namespace_prefixes}{
$namespace
};
if
(
$docprefix
&& !
$$self
{code_namespaces}{
$docprefix
}) {
$codeprefix
=
$docprefix
; }
else
{
$codeprefix
=
"namespace"
. (++
$$self
{namespace_errors}); }
$self
->registerNamespace(
$codeprefix
,
$namespace
);
Warn(
'malformed'
,
$namespace
,
undef
,
"No prefix has been registered for namespace '$namespace' (in code)"
,
"Using '$codeprefix' instead"
); }
return
$codeprefix
; } }
sub
getNamespace {
my
(
$self
,
$codeprefix
,
$probe
) =
@_
;
my
$ns
=
$$self
{code_namespaces}{
$codeprefix
};
if
((!
defined
$ns
) && !
$probe
) {
$self
->registerNamespace(
$codeprefix
,
Error(
'malformed'
,
$codeprefix
,
undef
,
"No namespace has been registered for prefix '$codeprefix' (in code)"
,
"Using '$ns' instead"
); }
return
$ns
; }
sub
registerDocumentNamespace {
my
(
$self
,
$docprefix
,
$namespace
) =
@_
;
$docprefix
=
'#default'
unless
defined
$docprefix
;
if
(
$namespace
) {
my
$regnamespace
= (
$docprefix
eq
'#default'
?
"DEFAULT#"
.
$namespace
:
$namespace
);
$$self
{document_namespace_prefixes}{
$regnamespace
} =
$docprefix
;
$$self
{document_namespaces}{
$docprefix
} =
$namespace
; }
else
{
my
$prev
=
$$self
{document_namespaces}{
$docprefix
};
delete
$$self
{document_namespace_prefixes}{
$prev
}
if
$prev
;
delete
$$self
{document_namespaces}{
$docprefix
}; }
return
; }
sub
getDocumentNamespacePrefix {
my
(
$self
,
$namespace
,
$forattribute
,
$probe
) =
@_
;
if
(
$namespace
) {
my
$docprefix
= (!
$forattribute
&&
$$self
{document_namespace_prefixes}{
"DEFAULT#"
.
$namespace
})
||
$$self
{document_namespace_prefixes}{
$namespace
}
|| ((
$namespace
ne
$LTX_NAMESPACE
) &&
$$self
{code_namespace_prefixes}{
$namespace
});
if
((!
defined
$docprefix
) && !
$probe
) {
$self
->registerDocumentNamespace(
$docprefix
=
"namespace"
. (++
$$self
{namespace_errors}),
$namespace
);
Warn(
'malformed'
,
$namespace
,
undef
,
"No prefix has been registered for namespace '$namespace' (in document)"
,
"Using '$docprefix' instead"
); }
return
((
$docprefix
||
'#default'
) eq
'#default'
?
''
:
$docprefix
); } }
sub
getDocumentNamespace {
my
(
$self
,
$docprefix
,
$probe
) =
@_
;
$docprefix
=
'#default'
unless
defined
$docprefix
;
my
$ns
=
$$self
{document_namespaces}{
$docprefix
};
$ns
=~ s/^DEFAULT
if
((
$docprefix
ne
'#default'
) && (!
defined
$ns
) && !
$probe
) {
$self
->registerDocumentNamespace(
$docprefix
,
Error(
'malformed'
,
$docprefix
,
undef
,
"No namespace has been registered for prefix '$docprefix' (in document)"
,
"Using '$ns' instead"
); }
return
$ns
; }
sub
decodeQName {
my
(
$self
,
$codetag
) =
@_
;
if
(
$codetag
=~ /^([^:]+):(.+)$/) {
my
(
$prefix
,
$localname
) = ($1, $2);
return
(
undef
,
$codetag
)
if
$prefix
eq
'xml'
;
return
(
$self
->getNamespace(
$prefix
),
$localname
); }
else
{
return
(
undef
,
$codetag
); } }
sub
encodeQName {
my
(
$self
,
$ns
,
$name
) =
@_
;
my
$codeprefix
=
$ns
&&
$self
->getNamespacePrefix(
$ns
);
return
(
$codeprefix
?
"$codeprefix:$name"
:
$name
); }
sub
getNodeQName {
my
(
$self
,
$node
) =
@_
;
my
$type
= (
$node
?
$node
->nodeType : -1);
if
(
$type
== XML_TEXT_NODE) {
return
'#PCDATA'
; }
elsif
(
$type
== XML_DOCUMENT_NODE) {
return
'#Document'
; }
elsif
(
$type
== XML_COMMENT_NODE) {
return
'#Comment'
; }
elsif
(
$type
== XML_PI_NODE) {
return
'#ProcessingInstruction'
; }
elsif
(
$type
== XML_DTD_NODE) {
return
'#DTD'
; }
elsif
(
$type
== XML_NAMESPACE_DECL) {
my
$ns
=
$node
->declaredURI;
my
$prefix
=
$ns
&&
$self
->getNamespacePrefix(
$ns
, 0, 1);
return
(
$prefix
?
'xmlns:'
.
$prefix
:
'xmlns'
); }
elsif
((
$type
!= XML_ELEMENT_NODE) && (
$type
!= XML_ATTRIBUTE_NODE)) {
Fatal(
'misdefined'
,
'<caller>'
,
undef
,
"Should not ask for Qualified Name for node of type $type: "
. Stringify(
$node
));
return
; }
else
{
my
$ns
=
$node
->namespaceURI;
my
$prefix
=
$ns
&&
$self
->getNamespacePrefix(
$ns
, 0, 1);
return
(
$prefix
?
$prefix
.
":"
.
$node
->localname :
$node
->localname); } }
sub
getNodeDocumentQName {
my
(
$self
,
$node
) =
@_
;
my
$type
=
$node
->nodeType;
if
(
$type
== XML_TEXT_NODE) {
return
'#PCDATA'
; }
elsif
(
$type
== XML_DOCUMENT_NODE) {
return
'#Document'
; }
elsif
(
$type
== XML_COMMENT_NODE) {
return
'#Comment'
; }
elsif
(
$type
== XML_PI_NODE) {
return
'#ProcessingInstruction'
; }
elsif
(
$type
== XML_DTD_NODE) {
return
'#DTD'
; }
elsif
(
$type
== XML_NAMESPACE_DECL) {
my
$ns
=
$node
->declaredURI;
my
$prefix
=
$ns
&&
$self
->getDocumentNamespacePrefix(
$ns
, 0, 1);
return
(
$prefix
?
'xmlns:'
.
$prefix
:
'xmlns'
); }
elsif
((
$type
!= XML_ELEMENT_NODE) && (
$type
!= XML_ATTRIBUTE_NODE)) {
Fatal(
'misdefined'
,
'<caller>'
,
undef
,
"Should not ask for Qualified Name for node of type $type: "
. Stringify(
$node
));
return
; }
else
{
my
$ns
=
$node
->namespaceURI;
my
$prefix
=
$ns
&&
$self
->getDocumentNamespacePrefix(
$ns
, 0, 1);
return
(
$prefix
?
$prefix
.
":"
.
$node
->localname :
$node
->localname); } }
sub
recodeDocumentQName {
my
(
$self
,
$docQName
) =
@_
;
my
(
$docprefix
,
$name
) = (
undef
,
$docQName
);
if
(
$docQName
=~ /^(
return
$docQName
; }
else
{
(
$docprefix
,
$name
) = ($1, $2)
if
$docQName
=~ /^([^:]+):(.+)/;
return
$self
->encodeQName(
$self
->getDocumentNamespace(
$docprefix
),
$name
); } }
sub
getXPath {
my
(
$self
) =
@_
;
return
$$self
{xpath}; }
sub
getTags {
my
(
$self
) =
@_
;
return
(
sort
keys
%{
$$self
{tagprop} }); }
sub
getTagContents {
my
(
$self
,
$tag
) =
@_
;
my
$h
=
$$self
{tagprop}{
$tag
}{model};
return
(
$h
?
sort
keys
%$h
: ()); }
sub
addTagContent {
my
(
$self
,
$tag
,
@elements
) =
@_
;
$$self
{tagprop}{
$tag
}{model} = {}
unless
$$self
{tagprop}{
$tag
}{model};
map
{
$$self
{tagprop}{
$tag
}{model}{
$_
} = 1 }
@elements
;
return
; }
sub
getTagAttributes {
my
(
$self
,
$tag
) =
@_
;
my
$h
=
$$self
{tagprop}{
$tag
}{attributes};
return
$h
?
sort
keys
%$h
: (); }
sub
addTagAttribute {
my
(
$self
,
$tag
,
@attributes
) =
@_
;
$$self
{tagprop}{
$tag
}{attributes} = {}
unless
$$self
{tagprop}{
$tag
}{attributes};
map
{
$$self
{tagprop}{
$tag
}{attributes}{
$_
} = 1 }
@attributes
;
return
; }
sub
setSchemaClass {
my
(
$self
,
$classname
,
$content
) =
@_
;
$$self
{schemaclass}{
$classname
} =
$content
;
return
; }
sub
canContain {
my
(
$self
,
$tag
,
$childtag
) =
@_
;
$self
->loadSchema
unless
$$self
{schema_loaded};
return
0
if
!
$tag
|| (
$tag
eq
'#PCDATA'
) || (
$tag
eq
'#Comment'
);
return
1
if
$tag
=~ /(.*?:)?_Capture_$/;
return
1
if
$tag
eq
'_WildCard_'
;
return
1
if
$childtag
=~ /(.*?:)?_Capture_$/;
return
1
if
$childtag
=~ /(.*?:)?_CaptureBlock_$/;
return
1
if
$childtag
eq
'_WildCard_'
;
return
1
if
$childtag
eq
'#Comment'
;
return
1
if
$childtag
eq
'#ProcessingInstruction'
;
return
1
if
$childtag
eq
'#DTD'
;
return
1
if
$$self
{permissive} && (
$tag
eq
'#Document'
) && (
$childtag
ne
'#PCDATA'
); # No DTD? Punt!
my
$model
=
$$self
{tagprop}{
$tag
}{model};
if
(!
$model
&& (
$tag
=~ /^(\w*):/)) {
my
$xtag
= $1 .
':*'
;
$model
=
$$self
{tagprop}{
$xtag
}{model}; }
my
(
$chns
,
$chname
) = (
$childtag
=~ /^([^:]*):(.*)$/ ? ($1, $2) : (
undef
,
$childtag
));
if
(
$chns
) {
return
(
$$model
{
$childtag
} ? 1
: (
$$model
{
"!$childtag"
} ? 0
: (
$$model
{
"$chns:*"
} ? 1
: (
$$model
{
"!$chns:*"
} ? 0
: (
$$model
{
'!*:*'
} ? 0
: (
$$model
{
'*:*'
} ? 1
: 0)))))); }
else
{
return
(
$$model
{
$childtag
} ? 1
: (
$$model
{
"!$childtag"
} ? 0
: (
$$model
{
'!*'
} ? 0
: (
$$model
{
'*'
} ? 1
: 0)))); } }
sub
canHaveAttribute {
my
(
$self
,
$tag
,
$attrib
) =
@_
;
$self
->loadSchema
unless
$$self
{schema_loaded};
return
0
if
$tag
eq
'#PCDATA'
;
return
0
if
$tag
eq
'#Comment'
;
return
0
if
$tag
eq
'#Document'
;
return
0
if
$tag
eq
'#ProcessingInstruction'
;
return
0
if
$tag
eq
'#DTD'
;
return
1
if
$tag
=~ /(.*?:)?_Capture_$/;
return
1
if
$attrib
=~ /^_/;
return
1
if
$$self
{permissive};
my
(
$tagns
,
$tagname
) = (
$tag
=~ /^(\w+):(\w*)$/ ? ($1, $2) : (
''
,
$tag
));
my
(
$attrns
,
$attrname
) = (
$attrib
=~ /^(\w+):(\w*)$/ ? ($1, $2) : (
''
,
$attrib
));
my
$attr
=
$$self
{tagprop}{
$tag
}{attributes};
if
(!
$attr
&& (
$tag
=~ /^(\w*):/)) {
my
$xtag
= $1 .
':*'
;
$attr
=
$$self
{tagprop}{
$xtag
}{attributes}; }
if
(
$attrns
) {
return
(
$$attr
{
$attrib
} ? 1
: (
$$attr
{
"!$attrib"
} ? 0
: (
$$attr
{
"$attrns:*"
} ? 1
: (
$$attr
{
"!$attrns:*"
} ? 0
: (
$$attr
{
'!*:*'
} ? 0
: (
$$attr
{
'*:*'
} ? 1
: 0)))))); }
else
{
return
(
$$attr
{
$attrib
} ? 1
: (
$$attr
{
"!$attrib"
} ? 0
: (
$$attr
{
'!*'
} ? 0
: (
$$attr
{
'*'
} ? 1
: 0)))); } }
sub
getSchemaClassNames {
my
(
$self
,
$classname
) =
@_
;
$self
->loadSchema
unless
$$self
{schema_loaded};
my
$class_data
=
$$self
{schemaclass}{
$classname
};
return
$class_data
? (
keys
%$class_data
) : (); }
sub
isInSchemaClass {
my
(
$self
,
$classname
,
$tag
) =
@_
;
$self
->loadSchema
unless
$$self
{schema_loaded};
$tag
=
$self
->getNodeQName(
$tag
)
if
ref
$tag
;
my
$class
=
$$self
{schemaclass}{
$classname
};
return
$class
&&
$$class
{
$tag
}; }
sub
isKnownTag {
my
(
$self
,
$name
) =
@_
;
return
exists
(
$$self
{tagprop}{
$name
}); }
sub
describeModel {
my
(
$self
) =
@_
;
Debug(
"Doctype"
);
foreach
my
$tag
(
sort
keys
%{
$$self
{tagprop} }) {
if
(
my
$model
=
$$self
{tagprop}{
$tag
}{model}) {
if
(
keys
%$model
) {
Debug(
"$tag can contain "
.
join
(
', '
,
sort
keys
%{
$$self
{tagprop}{
$tag
}{model} })); } }
else
{
Debug(
"$tag is empty"
); }
}
return
; }
1;