/packages/xoXSD/lib/Core.xotcl
Unknown | 1053 lines | 884 code | 169 blank | 0 comment | 0 complexity | 79a04b362a5773256d40c0af276b6f24 MD5 | raw file
- package provide xoXSD::Core 0.1
- package require tdom
- package require xoXSD::DataTypes
- namespace eval ::xoXSD {
- variable __quiet false
- proc hideErrors {value} {
- variable __quiet
- if { $value eq 0 || $value eq false || $value eq 1 || $value eq true } {
- set __quiet $value
- }
- }
- ##############################################
- # * Definition * #
- ##############################################
-
- ::xotcl::Class XSDObject -superclass ::xotcl::Class -slots {
- ::xotcl::Attribute __elements
- ::xotcl::Attribute __attributes
- ::xotcl::Attribute __childslots
- ::xotcl::Attribute __children
- ::xotcl::Attribute __choiceParents -default ""
- }
-
- ::xotcl::Class XSDChildObject -superclass ::xoXSD::XSDObject
- ::xotcl::Class Element -superclass ::xoXSD::XSDObject
- ::xotcl::Class ComplexType -superclass ::xoXSD::XSDObject
- ::xotcl::Class Sequence -superclass ::xoXSD::XSDChildObject -slots {
- ::xotcl::Attribute __sequence -default false
- }
- ::xotcl::Class Choice -superclass ::xoXSD::XSDChildObject -slots {
- ::xotcl::Attribute __assignedElement -default ""
- }
-
- ##############################################
- # * Constructors * #
- ##############################################
- XSDObject instproc init args {
- set heritage [list]
- foreach c [[my class] info heritage] {
- if { [namespace qualifiers $c] eq "::xoXSD" } break
- lappend heritage $c
- }
- my __children [list]
- my __childslots [list]
- my __elements [list]
- my __attributes [list]
-
- # create new instances of all classchildren
- foreach c [concat [my class] [lreverse $heritage]] {
- foreach child [$c info classchildren] {
- set ch [eval $child new -childof [self]]
- my [namespace tail [$ch class]] $ch
- my lappend __children $ch
- }
- }
-
- foreach slot [my __getLocalSlots] {
- set slotclass [namespace tail [$slot class]]
-
- if { $slotclass eq "XMLAttribute" } {
- my __addAttribute $slot
- } elseif { $slotclass eq "XMLElement" } {
- my __addElement $slot
- } elseif { $slotclass eq "XMLChild" } {
- my lappend __childslots $slot
- }
- }
-
- # get "choice-parents"...
- set parent [my info parent]
- while { [Object isobject $parent] } {
- set cls [namespace tail [$parent class]]
- if { [string match "__choice*" $cls] } {
- my lappend __choiceParents $parent
- }
- set parent [$parent info parent]
- }
-
- # init text-only elements with the given string $args
- if { [llength $args] > 0 } {
- if { [my __slotExists __text] } {
- my __text [join $args]
- }
- }
- }
- Sequence instproc init args {
- # XSDObject->init
- next
-
- set slots [list]
- foreach slot [my __getLocalSlots] {
- if { [namespace tail [$slot class]] eq "XMLAttribute" } {
- continue
- }
- lappend slots [list $slot [$slot sequence]]
- }
-
- my __sequence [list]
- foreach slot [lsort -integer -index 1 $slots] {
- set slot [lindex $slot 0]
- set slotname [namespace tail $slot]
- set slotclass [namespace tail [$slot class]]
-
- if { $slotclass eq "XMLChild" } {
- foreach child [my __children] {
- set childclass [namespace tail [$child class]]
- if { $childclass eq $slotname } {
- my lappend __sequence $child
- }
- }
- } else {
- my lappend __sequence $slot
- }
- }
-
- # add the missing childclasses (with no sequence)
- foreach child [my __children] {
- if { [lsearch [my __sequence] $child] == -1 } {
- my lappend __sequence $child
- }
- }
- }
- ##############################################
- # * Various "publicly" available functions * #
- ##############################################
- XSDObject instproc check {} {
- foreach slot [my __attributes] {
- if { [$slot use] eq "required" && ![my __slotFilled $slot] } {
- my __error "Missing attribute: [namespace tail $slot] (type: [$slot getType])"
- return 0
- }
- }
-
- foreach slot [my __elements] {
- if { ![my __checkMinOccurs $slot] } {
- return 0
- }
- }
- foreach child [my __getAllChildren] {
- if { ![$child check] } {
- return 0
- }
- }
- return 1
- }
- Sequence instproc check {} {
- return [my __checkMinOccursSelf]
- }
- Choice instproc check {} {
- if { ![my __checkMinOccursSelf] } {
- return 0
- }
- if { [my __assignedElement] eq "" } {
- set slot [my __getParentSlot]
- if { [my __choiceParents] eq "" && [$slot minOccurs] > 0 } {
- my __error "A child-element of \"[my class]\" has to be assigned!"
- return 0
- }
- foreach o [my __choiceParents] {
- set assigned [string map {"::slot" ""} [$o __assignedElement]]
- if { [my __isInSameNamespace [my class] $assigned] && ![$o __checkMinOccursSelf] } {
- my __error "A child-element of \"[my class]\" has to be assigned!"
- return 0
- }
- }
- }
- return 1
- }
- XSDObject instproc marshal { -name {-compact:boolean false} } {
- if { ![my check] } {
- my __error "The object cannot be marshalled because it is not valid."
- return ""
- }
-
- # create the document:
- set doc [dom createDocument [my __getXmlElementMarshalName]]
- set root [$doc documentElement]
-
- # add the xmlns-attributes:
- if { [self callingproc] ne "__marshalElement" } {
- set prefix [my __getXmlPrefix]
- $root setAttribute "xmlns:$prefix" [my __getXmlNamespace]
- my __setXmlnsAttributes $root
- }
-
- # add the attributes:
- my __marshalAttributes $doc $root
-
- # add the containing sub-elements:
- my __marshalElements $doc $root
- set xml [$root asXML]
-
- # prevent memory leaking:
- $doc delete
-
- # strip all whitespaces between elements:
- if { $compact } {
- regsub -all {>\s+<} $xml {><} xml
- regsub -all {\n} $xml {} xml
- }
- return $xml
- }
- XSDObject instproc print { {-compact:boolean false} } {
- puts " "
- puts "Marshalling [self] ([my class]) ..."
- puts [my marshal -compact $compact]
- }
- XSDObject instproc printContent {} {
- set content [my getContent]
- if { $content == false } {
- my __error "I don't have any textual content."
- return
- }
- puts "The textual content of [self] is:\n$content"
- }
- XSDObject instproc getContent {} {
- set content [my __getSlot __text]
- if { $content ne "" } {
- return [$content getContent]
- }
- return ""
- }
- XSDObject instproc setContent {text} {
- if { [my __slotExists __text] } {
- return [my __text $text]
- }
- my __error "There is no textual content to be set."
- return 0
- }
-
- XSDObject instproc printSlots {} {
- # first get a list of all elements and attributes:
- set elements [my __elements]
- set attributes [my __attributes]
- foreach child [my __getAllChildren] {
- set elements [concat $elements [$child __elements ]]
- set attributes [concat $attributes [$child __attributes]]
- }
-
- set classname [namespace tail [my class]]
- set headers [list "Name" "Type" "Additional Information"]
-
- if { [llength $elements] > 0 } {
- set content [list]
- foreach e $elements {
- lappend content [list [$e getName $e] [$e getType] [$e getInfo]]
- }
- puts [my __makeTable "Elements of \"$classname\"" $headers $content]
- }
- if { [llength $attributes] > 0 } {
- set content [list]
- foreach a $attributes {
- lappend content [list [$a getName $a] [$a getType] [$a getInfo]]
- }
- puts [my __makeTable "Attributes of \"$classname\"" $headers $content]
- }
- }
-
- XSDObject instproc addAny {slot} {
- set slot [my __lookupObject $slot]
- set slotname [namespace tail [$slot class]]
-
- # first check if the element actually has an <any> element:
- set any [my __getSlotClass __any]
- if { $any == false } {
- my __error "There is no <any> element to be set."
- return false
- }
-
- # search for the class/instance that has the __any slot defined:
- set cls [[$any info parent] info parent]
- set inst ""
- foreach inst [my __getAllChildren -includeMyself true] {
- set c [$inst class]
- if { $c eq $cls || [lsearch [$c info heritage] $cls] != -1 } {
- break
- }
- }
- if { $inst eq "" } { error "should not reach here. didn't find inst!" }
-
- # check if a slot named $slotname already exists:
- if { [$inst __slotExists $slotname] } {
- my __error "An element called \"$slotname\" has already been added before."
- return false
- }
-
- # check for maxOccurs restrictions:
- set anyslot "$cls\::slot\::__any"
- set anyCounter [$anyslot anyCounter]
- set maxOccurs [$anyslot maxOccurs]
- if { $maxOccurs ne "unbounded" } {
- if { $anyCounter >= $maxOccurs } {
- my __error "The element cannot be added because of a maxOccurs restriction."
- return false
- }
- }
-
- # check for namespace restrictions:
- set namespaces [split [$anyslot namespace] " "]
- if { ![my __checkAnyNamespaceRestrictions $namespaces $inst $slot] } {
- my __error "The element cannot be added because of namespace restrictions."
- return false
- }
-
- set slotargs " -type [$slot class]"
- if { $maxOccurs eq "unbounded" || $maxOccurs > 1 } {
- append slotargs " -maxOccurs $maxOccurs -multivalued true"
- }
-
- # dynamically create and add a new slot to the class
- $cls slots "::xoXSD::Slots::XMLElement $slotname $slotargs"
- $inst __addElement "$cls\::slot\::$slotname"
-
- # update the anyCounter if necessary
- if { $maxOccurs ne "unbounded" } {
- $anyslot anyCounter [incr anyCounter]
- }
-
- # finally set the newly created slot
- return [my __setSlot $slotname $slot]
- }
-
- XSDObject instproc addAnyAttribute {slotname type {value ""}} {
- # first check if the element actually has an <any> element:
- set anyAttribute [my __getSlotClass __anyAttribute]
- if { $anyAttribute == false } {
- my __error "There is no <anyAttribute> attribute to be set."
- return false
- }
-
- # check the given type:
- if { [string equal -length 5 $type "xsd::"] } {
- set type [string map {"xsd::" "::xoXSD::DataTypes::"} $type]
- }
- if { ![::xotcl::Class isclass $type] } {
- my __error "The given type ($type) is undefined."
- return false
- }
- if { ![lsearch -not [$type info heritage] "::xoXSD::DataTypes::DataType"] } {
- my __error "The given type ($type) doesn't seem to be a simple datatype."
- return false
- }
-
- # search for the class/instance that has the __anyAttribute slot defined:
- set cls [[$anyAttribute info parent] info parent]
- set inst ""
- foreach inst [my __getAllChildren -includeMyself true] {
- set c [$inst class]
- if { $c eq $cls || [lsearch [$c info heritage] $cls] != -1 } {
- break
- }
- }
- if { $inst eq "" } { error "should not reach here. didn't find inst!" }
-
- # check for namespace restrictions:
- set anyslot "$cls\::slot\::__anyAttribute"
- set namespaces [split [$anyslot namespace] " "]
- set content [$type new $value]
- if { ![my __checkAnyNamespaceRestrictions $namespaces $inst $content] } {
- my __error "The attribute cannot be assigned because of namespace restrictions."
- return false
- }
-
- # dynamically create and add a new slot to the class
- $cls slots "::xoXSD::Slots::XMLAttribute $slotname -type $type"
- $inst __addAttribute "$cls\::slot\::$slotname"
-
- # finally set the newly created slot
- my $slotname $content
- }
- XSDObject instproc isAssigned {slot} {
- return [my __slotFilled -recursive true $slot]
- }
- XSDObject instproc . {accessor args} {
- if { [llength [my $accessor]] > 1 } {
- set dots [expr [llength [split $args .]] - 1]
- if { $dots < 1 && $args ne "" } {
- my __error "Cannot execute the function \"[string trim $args]\" because \"$accessor\" returned multiple objects."
- return
- }
- if { $dots > 0 } {
- my __error "Cannot access \"[string trimleft $args { .}]\" because \"$accessor\" returned multiple objects."
- }
- return [my $accessor]
-
- } elseif { [my $accessor] eq "" } {
- my __error "The element or attribute \"$accessor\" doesn't exist."
- return ""
-
- } else {
- return [[my $accessor] {*}$args]
- }
- }
- XSDObject instforward export %self marshal
- ##############################################
- # * Various helper functions * #
- # Note: you shouldn't call them directly. #
- ##############################################
- XSDObject instproc __marshalAttributes {doc root} {
- # iterate over all attributes
- foreach attribute [my __attributes] {
- my __marshalAttribute $doc $root $attribute
- }
-
- # do the same with all children
- foreach child [my __children] {
- $child __marshalAttributes $doc $root
- }
- }
- XSDObject instproc __marshalAttribute {doc root attribute} {
- if { ![my __slotFilled $attribute] } return
-
- set content [[my [namespace tail $attribute]] getContent]
- if { [$attribute text] } {
- $root appendChild [$doc createTextNode $content]
- } else {
- $root setAttribute [namespace tail $attribute] $content
- }
- }
- XSDObject instproc __marshalElements {doc root} {
- # iterate over all elements
- foreach element [my __elements] {
- my __marshalElement $doc $root $element
- }
-
- # do the same with all children
- foreach child [my __children] {
- $child __marshalElements $doc $root
- }
- }
- Sequence instproc __marshalElements {doc root} {
- foreach obj [my __sequence] {
- if { [string match "*::slot::*" $obj ] } {
- my __marshalElement $doc $root $obj
- } else {
- $obj __marshalElements $doc $root
- }
- }
- }
- XSDObject instproc __marshalElement {doc root element} {
- if { ![my __slotFilled $element] } return
- set name [my __getXmlElementMarshalName $element]
- foreach element [my [namespace tail $element]] {
- set xml [$element marshal -name $name]
- if { $xml ne "" } {
- $root appendXML $xml
- }
- }
- }
- XSDObject instproc __setXmlnsAttributes {root} {
- foreach element [my __elements] {
- set element [namespace tail $element]
- if { ![my __slotFilled $element] } continue
-
- set element [lindex [my $element] 0]
- set ns [$element __getXmlNamespace]
- set prefix [$element __getXmlPrefix]
-
- if { $prefix ne "" } {
- $root setAttribute "xmlns:$prefix" $ns
- }
- }
- foreach child [my __children] {
- $child __setXmlnsAttributes $root
- }
- }
-
- XSDObject instproc __getXmlElementMarshalName { {element ""} } {
- if { $element eq "" } {
- set element [my class]
- }
- set name [namespace tail $element]
- set prefix [my __getXmlPrefix]
- if { $prefix ne "" } {
- set name "$prefix:$name"
- }
- return $name
- }
- XSDObject instproc __getRootNamespaceVariable {varname} {
- foreach c [concat [my class] [[my class] info heritage]] {
- regsub -all {::__choice\d+} $c {} c
- regsub -all {::__sequence\d+} $c {} c
- set qualifiers [namespace qualifiers $c]
- if { $qualifiers eq "::xoXSD" } break
- if { [namespace eval $qualifiers info exists $varname] } {
- namespace upvar $qualifiers $varname var
- return $var
- }
- }
- error "shouldn't reach here"
- }
- XSDObject instproc __getXmlNamespace {} {
- return [my __getRootNamespaceVariable xmlNamespace]
- }
- XSDObject instproc __getXmlPrefix {} {
- return [my __getRootNamespaceVariable xmlPrefix]
- }
- XSDObject instproc __getSlotClass { {-withChildSlots:boolean false} slot } {
- set slotclass [my __doGetSlotClass -withChildSlots $withChildSlots $slot]
- if { $slot == false } {
- my __error "there is no such slot: $slot"
- return false
- }
- return $slotclass
- }
- XSDObject instproc __getSlots { {-withChildSlots:boolean false} } {
- if { $withChildSlots } {
- return [concat [my __elements] [my __attributes] [my __childslots]]
- }
- return [concat [my __elements] [my __attributes]]
- }
- XSDObject instproc __getLocalSlots {} {
- # now create a list of all slots
- set slots [[my class] info slots]
-
- # remember slotnames
- foreach slot $slots {set slotname([namespace tail $slot]) 1}
-
- # iterate over class structure
- set heritage [[my class] info heritage]
- foreach c [lsearch -inline -all -not $heritage "::xoXSD::*"] {
- foreach slot [$c info slots] {
- set key slotname([namespace tail $slot])
-
- # don't add slots which are already defined in
- # more specialized classes
- if {[info exists $key]} continue
- set $key 1
- lappend slots $slot
- }
- }
-
- return $slots
- }
- XSDObject instproc __getSlotType {slot} {
- # returns either XMLAttribute, XMLElement, XMLChild or false
- set slotclass [my __getSlotClass $slot]
- if { $slotclass == false } { return false }
- return [namespace tail [$slotclass class]]
- }
- XSDObject instproc __getSlot {slot} {
- foreach o [my __getAllChildren -includeMyself true] {
- set r [$o __doGetSlot $slot]
- if { $r ne "false" } {
- return $r
- }
- }
- my __error "There is no such Element: $slot"
- return ""
- }
- XSDObject instproc __doGetSlot {slot} {
- set slot [namespace tail $slot]
-
- if { ![my __slotExists $slot] || ![my exists [namespace tail $slot]] } {
- return false
- }
-
- set parent [my info parent]
- if { [Object isobject $parent] && [$parent class] ne "::xoXSD::CodeGenerator"} {
- set classname [namespace tail [my class]]
- set c [$parent __getSlotClass -withChildSlots true $classname]
-
- if { [$c multivalued] } {
- set slots [list]
- foreach child [$parent $classname] {
- if { [$child exists $slot] } {
- lappend slots [$child $slot]
- }
- }
- if { [llength $slots] == 0 } {
- return false
- }
- return $slots
- }
- }
-
- return [my $slot]
- }
- XSDObject instproc __setSlot {slot value} {
- if { [Object isobject $value] && ![$value check] } {
- my __error "Cannot assign \"$value\" because it is not valid."
- return false
- }
- foreach o [my __getAllChildren -includeMyself true] {
- if { [$o __doSetSlot $slot $value] } {
- return true
- }
- }
- if { ![my __slotExists -recursive true $slot] } {
- my __error "There is no such Element: $slot"
- }
- return false
- }
- XSDObject instproc __doSetSlot {slot value} {
- set slot [namespace tail $slot]
- if { ![my __slotExists $slot] } {
- return false
- }
-
- # check the choice-parents if we're allowed to set an element
- foreach o [my __choiceParents] {
- if { ![$o __isAssignmentAllowed] } {
- return false
- }
- }
-
- set c [my __getSlotClass $slot]
- if { ![Object isobject $value] } {
- my __error "I am expecting an Object of type [$c getType] but \"$value\" doesn't seem to be one."
- return false
- }
-
- # check if the given value-object matches the required type
- if { [$c type] ne [$value class] } {
- if { [$c type] ne [[$value class] info superclass] } {
- my __error "\"$slot\" has to be of type [$c getType]"
- return false
- }
- }
-
- # check for a simpleType's enumeration restriction
- set enum [list]
- if { [$c exists enumvalues] } {
- set enum [$c enumvalues]
- }
- if { [llength $enum] > 0 } {
- if { [lsearch -exact $enum [$value getContent]] == -1 } {
- my __error "\"$slot\" is not correctly formatted."
- return false
- }
- }
-
- # check for multivalued slots
- if { [$c multivalued] && [my __slotFilled $slot] } {
- set occurs [llength [my $slot]]
- set maxOccurs [$c maxOccurs]
- if { $maxOccurs eq "unbounded" || $occurs < $maxOccurs } {
- # add the slot
- my $slot add $value
- return true
-
- } else {
- my __error "\"$slot\" cannot be set because of a maxOccurs restriction."
- return false
- }
- }
-
- # assign the slot
- my $slot $value
-
- # tell the choice-parents that we've set an element
- my __updateChoiceParents
-
- # finally return true
- return true
- }
- XSDObject instproc __updateChoiceParents { } { }
- XSDChildObject instproc __updateChoiceParents {} {
- foreach o [my __choiceParents] {
- set slot [lindex [split [string range [string map [list [$o class] ""] [my class]] 2 end] "::"] 0]
- $o __setAssignedElement $slot
- }
- }
-
- Choice instproc __setAssignedElement {slot} {
- if { [my __assignedElement] ne "" } return
- my __assignedElement "[my class]::slot::$slot"
- }
- Choice instproc __isInSameNamespace {c1 c2} {
- set len [string length $c1]
- return [string equal -length $len $c2 $c1]
- }
- Choice instproc __isAssignmentAllowed {} {
- if { [my __assignedElement] eq "" } {
- return true
- }
-
- if { [namespace tail [[my __assignedElement] class]] eq "XMLElement" } {
- return false
- }
-
- set assigned [string map {"::slot" ""} [my __assignedElement]]
- set caller [[self callingobject] class]
-
- return [my __isInSameNamespace $assigned $caller]
- }
- Choice instproc __doSetSlot {slot value} {
- if { ![my __slotExists $slot] } {
- return false
- }
-
- if { [my __isAssignmentAllowed] } {
- if { [next] } {
- my __setAssignedElement $slot
- return true
- } else {
- return false
- }
- }
- if { [my __tryCreateChild $slot $value] } {
- return true
- }
-
- if { [my __assignedElement] eq "" || [namespace tail [[my __assignedElement] class]] eq "XMLElement" } {
- my __error "Cannot assign \"$slot\" because of an XML Schema Choice restriction."
- }
-
- return false
- }
-
- Sequence instproc __doSetSlot {slot value} {
- if { ![my __slotExists $slot] } {
- return false
- }
-
- if { [next] } {
- return true
- }
-
- if { [my __tryCreateChild $slot $value] } {
- return true
- }
- return false
- }
-
- XSDChildObject instproc __tryCreateChild {slot value} {
- set name [namespace tail [my class]]
- set parent [my info parent]
- set c [$parent __getSlotClass -withChildSlots true $name]
-
- if { ![$c multivalued] } {
- return false
- }
-
- set occurs [llength [$parent $name]]
- set maxOccurs [$c maxOccurs]
- if { $maxOccurs eq "unbounded" || $occurs < $maxOccurs } {
- set ch [eval [my class] new -childof $parent]
-
- $parent $name add $ch
- $parent __addChild $ch
-
- return [$ch __doSetSlot $slot $value]
- }
- return false
- }
- XSDObject instproc __doGetSlotClass { {-withChildSlots:boolean false} slot } {
- set slot [namespace tail $slot]
- if { ![my __slotExists -withChildSlots $withChildSlots $slot] } {
- foreach child [my __children] {
- set result [$child __doGetSlotClass $slot]
- if { $result != false } { return $result }
- }
- return false
-
- } else {
- return [lsearch -inline -glob [my __getSlots -withChildSlots $withChildSlots] "*::$slot"]
- }
- }
- XSDObject instproc __error {msg} {
- variable __quiet
- if { $__quiet } return
- puts " "
- puts "An ERROR occured:"
- puts " o) Object: [self]"
- puts " o) Type: [my class]"
- puts " o) Proc: [self callingproc]"
- puts " o) Message: [join $msg]"
- puts " "
- }
- XSDObject instproc __slotExists { {-withChildSlots:boolean false} {-recursive:boolean false} slot } {
- if { $recursive } {
- set children [my __getAllChildren -includeMyself true]
- } else {
- set children [self]
- }
- foreach o $children {
- if { [lsearch [$o __getSlots -withChildSlots $withChildSlots] "*::slot::[namespace tail $slot]"] != -1 } {
- return 1
- }
- }
- return 0
- }
- XSDObject instproc __slotFilled { {-recursive:boolean false} {-exact:boolean false} slot } {
- if { $recursive } {
- set children [my __getAllChildren -includeMyself true]
- } else {
- set children [self]
- }
-
- foreach o $children {
- set name [namespace tail $slot]
- if { [$o exists $name] } {
- set occurs [llength [$o $name]]
- if { $exact && [namespace qualifiers [namespace qualifiers $slot]] ne [$o class] } {
- continue
- }
- return $occurs
- }
- }
-
- return 0
- }
- XSDObject instproc __getAllChildren { {-includeMyself:boolean false} } {
- set children [my __children]
- foreach child [my __children] {
- set children [concat $children [$child __getAllChildren]]
- }
- if { $includeMyself } {
- set children [concat [self] $children]
- }
- return $children
- }
-
- XSDObject instproc __addElement {element} {
- my lappend __elements $element
- }
-
- Sequence instproc __addElement {element} {
- next
- my lappend __sequence $element
- }
-
- XSDObject instproc __addAttribute {attribute} {
- my lappend __attributes $attribute
- }
- XSDObject instproc __addChild {child} {
- my lappend __children $child
- }
- Sequence instproc __addChild {child} {
- next
- my lappend __sequence $child
- }
-
- XSDObject instproc __checkAnyNamespaceRestrictions {namespaces inst value} {
- if { [lsearch $namespaces "##any"] != -1 } {
- return true
-
- } elseif { [lsearch $namespaces "##other"] != -1 } {
- if { [$value __getXmlNamespace] ne [$inst __getXmlNamespace] } {
- return true
- }
-
- } elseif { [lsearch $namespaces "##targetNamespace"] != -1 } {
- if { [$value __getXmlNamespace] eq [$inst __getXmlNamespace] } {
- return true
- }
-
- } elseif { [lsearch $namespaces "##local"] != -1 } {
- if { [$value __getXmlNamespace] eq "" } {
- return true
- }
-
- } else {
- foreach ns $namespaces {
- if { $ns eq [$value __getXmlNamespace] } {
- return true
- }
- }
- }
-
- return false
- }
- XSDChildObject instproc __getParentSlot {} {
- set parent [[my info parent] class]
- set name [namespace tail [my class]]
-
- foreach c [concat $parent [$parent info heritage]] {
- set s "$c\::slot\::$name"
- if { [Object isobject $s] && [namespace tail [$s class]] eq "XMLChild"} {
- return $s
- }
- }
- error "shouldn't reach here."
- }
- XSDChildObject instproc __checkMinOccursSelf {} {
- set slot [my __getParentSlot]
- set name [namespace tail [my class]]
-
- if { [$slot minOccurs] > 0 } {
- if { [llength [[my info parent] $name]] < [$slot minOccurs] } {
- my __error "I need [$slot minOccurs] instances of the element: $name (type: [$slot getType])"
- return 0
- }
- }
- return 1
- }
- XSDObject instproc __checkMinOccurs {slot} {
- set name [namespace tail $slot]
- set validity 1
- if { [$slot minOccurs] > 0 } {
- if { ![my __slotFilled $slot] } {
- set validity 0
- my __error "Missing element: $name (type: [$slot getType])"
-
- } elseif { [llength [my $name]] < [$slot minOccurs] } {
- set validity 0
- my __error "I need [$slot minOccurs] instances of the element: $name (type: [$slot getType])"
- }
- }
- return $validity
- }
- XSDObject instproc __makeTable {tableheader headers content} {
- set width [list]
- foreach header $headers {
- lappend width [string length $header]
- }
- foreach line $content {
- for {set i 0} {$i < [llength $line]} {incr i} {
- set colMax 0
- foreach colLine [lindex $line $i] {
- set colMax [expr max($colMax, [string length $colLine])]
- }
- lset width $i [expr max($colMax, [lindex $width $i])]
- }
- }
-
- set sep "+"
- set lw 0
- foreach w $width {
- incr lw $w
- append sep "-[string repeat - $w]-+"
- }
- set o "+[string repeat - [expr $lw + 3 * [llength $headers] - 1]]+\n"
- append o "| [format "%-*s | " [expr $lw + 2 * [llength $headers]] $tableheader]\n"
-
- append o "$sep\n[my __makeTableRow $width $headers]$sep\n"
- foreach line $content {
- set colLinesMax 1
- foreach colLines $line {
- set colLinesMax [expr max($colLinesMax, [llength $colLines])]
- }
- set content [list]
- for {set i 0} {$i < $colLinesMax} {incr i} {
- set content [list]
- for {set j 0} {$j < [llength $line]} {incr j} {
- lappend content [lindex [lindex $line $j] $i]
- }
- append o [my __makeTableRow $width $content]
- }
- append o "$sep\n"
- }
- return $o
- }
- XSDObject instproc __makeTableRow {width content} {
- set line "| "
- for {set i 0} {$i < [llength $content]} {incr i} {
- append line [format "%-*s | " [lindex $width $i] [lindex $content $i]]
- }
- return "$line\n"
- }
- XSDObject instproc unknown {cmd args} {
- set args [join $args]
-
- #read slot
- if { $args eq "" } {
- return [my __getSlot $cmd]
- }
-
- #set slot...
- return [my __setSlot $cmd [my __lookupObject $args]]
- }
- XSDObject instproc __lookupObject {name} {
- set i 1
- set ns ""
- while { ![Object isobject "$ns\::$name"] } {
- # get the caller's namespace:
- if { [catch { set ns [uplevel [incr i] namespace current] } err] } {
- return $name
- }
- }
- return "$ns\::$name"
- }
- XSDObject instproc __namespaceQualifiers {ns {depth 1}} {
- while { $depth > 0 } {
- set ns [namespace qualifiers $ns]
- incr depth -1
- }
- return $ns
- }
- }