PageRenderTime 76ms CodeModel.GetById 2ms app.highlight 66ms RepoModel.GetById 1ms app.codeStats 0ms

/packages/xoXSD/lib/Core.xotcl

https://bitbucket.org/pgaubatz/xosaml
Unknown | 1053 lines | 884 code | 169 blank | 0 comment | 0 complexity | 79a04b362a5773256d40c0af276b6f24 MD5 | raw file
   1package provide xoXSD::Core 0.1
   2
   3package require tdom
   4package require xoXSD::DataTypes
   5
   6namespace eval ::xoXSD {
   7
   8variable __quiet false
   9
  10proc hideErrors {value} {
  11	variable __quiet
  12	if { $value eq 0 || $value eq false || $value eq 1 || $value eq true } {
  13		set __quiet $value
  14	}
  15}
  16
  17##############################################
  18#               * Definition *               #
  19##############################################	
  20	
  21::xotcl::Class XSDObject	-superclass ::xotcl::Class -slots {
  22	::xotcl::Attribute __elements
  23	::xotcl::Attribute __attributes
  24	::xotcl::Attribute __childslots
  25	::xotcl::Attribute __children
  26	::xotcl::Attribute __choiceParents -default ""
  27}
  28	
  29::xotcl::Class XSDChildObject	-superclass ::xoXSD::XSDObject 
  30
  31::xotcl::Class Element		-superclass ::xoXSD::XSDObject 
  32
  33::xotcl::Class ComplexType	-superclass ::xoXSD::XSDObject
  34
  35::xotcl::Class Sequence		-superclass ::xoXSD::XSDChildObject -slots {
  36	::xotcl::Attribute __sequence -default false
  37}
  38
  39::xotcl::Class Choice		-superclass ::xoXSD::XSDChildObject -slots {
  40	::xotcl::Attribute __assignedElement -default ""
  41}
  42	
  43##############################################
  44#              * Constructors *              #
  45##############################################
  46
  47XSDObject instproc init args {	
  48	set heritage [list]
  49	foreach c [[my class] info heritage] {
  50		if { [namespace qualifiers $c] eq "::xoXSD" } break
  51		lappend heritage $c
  52	}
  53
  54	my __children [list]
  55	my __childslots [list]
  56	my __elements [list]
  57	my __attributes [list]
  58	
  59	# create new instances of all classchildren
  60	foreach c [concat [my class] [lreverse $heritage]] {
  61		foreach	child [$c info classchildren] {
  62			set ch [eval $child new -childof [self]]
  63			my [namespace tail [$ch class]] $ch
  64			my lappend __children $ch
  65		}
  66	}
  67	
  68	foreach slot [my __getLocalSlots] {
  69		set slotclass [namespace tail [$slot class]]
  70		
  71		if { $slotclass eq "XMLAttribute" } {
  72			my __addAttribute $slot
  73		} elseif { $slotclass eq "XMLElement" } {
  74			my __addElement $slot
  75		} elseif { $slotclass eq "XMLChild" } {
  76			my lappend __childslots $slot
  77		}
  78	}
  79	
  80	# get "choice-parents"...
  81	set parent [my info parent]
  82	while { [Object isobject $parent] } {
  83		set cls [namespace tail [$parent class]]
  84		if { [string match "__choice*" $cls] } {
  85			my lappend __choiceParents $parent	
  86		}
  87		set parent [$parent info parent]
  88	}
  89	
  90	# init text-only elements with the given string $args
  91	if { [llength $args] > 0 } {
  92		if { [my __slotExists __text] } {
  93			my __text [join $args]
  94		}
  95	}
  96}
  97
  98Sequence instproc init args {
  99	# XSDObject->init
 100	next 
 101	
 102	set slots [list]
 103	foreach slot [my __getLocalSlots] {
 104		if { [namespace tail [$slot class]] eq "XMLAttribute" } {
 105			continue
 106		}
 107		lappend slots [list $slot [$slot sequence]]
 108	}
 109	
 110	my __sequence [list]
 111	foreach slot [lsort -integer -index 1 $slots] {
 112		set slot [lindex $slot 0]
 113		set slotname [namespace tail $slot]
 114		set slotclass [namespace tail [$slot class]]
 115		
 116		if { $slotclass eq "XMLChild" } {
 117			foreach child [my __children] {
 118				set childclass [namespace tail [$child class]]
 119				if { $childclass eq $slotname } {
 120					my lappend __sequence $child	
 121				}
 122			}
 123		} else {
 124			my lappend __sequence $slot
 125		}
 126	}
 127	
 128	# add the missing childclasses (with no sequence)
 129	foreach child [my __children] {
 130		if { [lsearch [my __sequence] $child] == -1 } {
 131			my lappend __sequence $child
 132		}
 133	}
 134}
 135
 136##############################################
 137# * Various "publicly" available functions * #
 138##############################################
 139
 140XSDObject instproc check {} {	
 141	foreach slot [my __attributes] {
 142		if { [$slot use] eq "required" && ![my __slotFilled $slot] } {
 143			my __error "Missing attribute: [namespace tail $slot] (type: [$slot getType])"
 144			return 0
 145		}
 146	}
 147	
 148        foreach slot [my __elements] {
 149    		if { ![my __checkMinOccurs $slot] } { 
 150    			return 0 
 151    		}
 152    	}
 153
 154	foreach child [my __getAllChildren] {
 155		if { ![$child check] } {
 156			return 0
 157		}
 158	}
 159
 160	return 1
 161}
 162
 163Sequence instproc check {} {
 164	return [my __checkMinOccursSelf]
 165}
 166
 167Choice instproc check {} {
 168	if { ![my __checkMinOccursSelf] } {
 169		return 0
 170	}
 171
 172	if { [my __assignedElement] eq "" } {
 173		set slot [my __getParentSlot]
 174		if { [my __choiceParents] eq "" && [$slot minOccurs] > 0 } {
 175			my __error "A child-element of \"[my class]\" has to be assigned!"
 176			return 0
 177		}
 178		foreach o [my __choiceParents] {
 179			set assigned [string map {"::slot" ""} [$o __assignedElement]]
 180			if { [my __isInSameNamespace [my class] $assigned] && ![$o __checkMinOccursSelf] } {
 181				my __error "A child-element of \"[my class]\" has to be assigned!"
 182				return 0
 183			}
 184		}
 185	}
 186
 187	return 1
 188}
 189
 190XSDObject instproc marshal { -name {-compact:boolean false} } {
 191	if { ![my check] } {
 192		my __error "The object cannot be marshalled because it is not valid."
 193		return ""
 194	}
 195	
 196	# create the document:
 197	set doc [dom createDocument [my __getXmlElementMarshalName]]
 198	set root [$doc documentElement]
 199	
 200	# add the xmlns-attributes:
 201	if { [self callingproc] ne "__marshalElement" } {
 202		set prefix [my __getXmlPrefix]	
 203		$root setAttribute "xmlns:$prefix" [my __getXmlNamespace]
 204		my __setXmlnsAttributes $root	
 205	}
 206	
 207	# add the attributes:
 208	my __marshalAttributes $doc $root
 209	
 210	# add the containing sub-elements:
 211	my __marshalElements $doc $root
 212
 213	set xml [$root asXML]
 214	
 215	# prevent memory leaking:
 216	$doc delete
 217	
 218	# strip all whitespaces between elements:
 219	if { $compact } {
 220		regsub -all {>\s+<} $xml {><} xml
 221		regsub -all {\n}    $xml {}   xml
 222	}
 223
 224	return $xml
 225}
 226
 227XSDObject instproc print { {-compact:boolean false} } {
 228	puts " "
 229	puts "Marshalling [self] ([my class]) ..."
 230	puts [my marshal -compact $compact]
 231}
 232
 233XSDObject instproc printContent {} {
 234	set content [my getContent]
 235	if { $content == false } {
 236		my __error "I don't have any textual content."
 237		return
 238	}
 239	puts "The textual content of [self] is:\n$content"
 240}
 241
 242XSDObject instproc getContent {} {
 243	set content [my __getSlot __text]
 244	if { $content ne "" } {
 245		return [$content getContent]	
 246	}
 247	return ""
 248}
 249
 250XSDObject instproc setContent {text} {
 251	if { [my __slotExists __text] } {
 252		return [my __text $text]
 253	}
 254	my __error "There is no textual content to be set."
 255	return 0
 256}
 257	
 258XSDObject instproc printSlots {} {
 259	# first get a list of all elements and attributes:
 260	set elements   [my __elements]
 261	set attributes [my __attributes]
 262	foreach child [my __getAllChildren] {
 263		set elements   [concat $elements   [$child __elements  ]]
 264		set attributes [concat $attributes [$child __attributes]]
 265	}
 266	
 267	set classname [namespace tail [my class]]
 268	set headers [list "Name" "Type" "Additional Information"]
 269	
 270	if { [llength $elements] > 0 } {
 271		set content [list]
 272		foreach e $elements {
 273			lappend content [list [$e getName $e] [$e getType] [$e getInfo]]
 274		}
 275		puts [my __makeTable "Elements of \"$classname\"" $headers $content]
 276	}
 277	if { [llength $attributes] > 0 } {
 278		set content [list]
 279		foreach a $attributes {
 280			lappend content [list [$a getName $a] [$a getType] [$a getInfo]]
 281		}
 282		puts [my __makeTable "Attributes of \"$classname\"" $headers $content]
 283	}
 284}
 285	
 286XSDObject instproc addAny {slot} {
 287	set slot [my __lookupObject $slot]
 288	set slotname [namespace tail [$slot class]]
 289	
 290	# first check if the element actually has an <any> element:
 291	set any [my __getSlotClass __any]
 292	if { $any == false } {
 293		my __error "There is no <any> element to be set."
 294		return false
 295	}
 296	
 297	# search for the class/instance that has the __any slot defined:
 298	set cls [[$any info parent] info parent]
 299	set inst ""
 300	foreach inst [my __getAllChildren -includeMyself true] {
 301		set c [$inst class]
 302		if { $c eq $cls || [lsearch [$c info heritage] $cls] != -1 } { 
 303			break
 304		}
 305	}
 306	if { $inst eq "" } { error "should not reach here. didn't find inst!" }
 307	
 308	# check if a slot named $slotname already exists:
 309	if { [$inst __slotExists $slotname] } {
 310		my __error "An element called \"$slotname\" has already been added before."
 311		return false
 312	}
 313	
 314	# check for maxOccurs restrictions:
 315	set anyslot "$cls\::slot\::__any"
 316	set anyCounter [$anyslot anyCounter]
 317	set maxOccurs [$anyslot maxOccurs]
 318	if { $maxOccurs ne "unbounded" } {
 319		if { $anyCounter >= $maxOccurs } {
 320			my __error "The element cannot be added because of a maxOccurs restriction."
 321			return false
 322		}
 323	}
 324	
 325	# check for namespace restrictions:
 326	set namespaces [split [$anyslot namespace] " "]
 327	if { ![my __checkAnyNamespaceRestrictions $namespaces $inst $slot] } {
 328		my __error "The element cannot be added because of namespace restrictions."
 329		return false
 330	}
 331	
 332	set slotargs " -type [$slot class]"
 333	if { $maxOccurs eq "unbounded" || $maxOccurs > 1 } {
 334		append slotargs " -maxOccurs $maxOccurs -multivalued true"
 335	}
 336	
 337	# dynamically create and add a new slot to the class
 338	$cls slots "::xoXSD::Slots::XMLElement $slotname $slotargs"
 339	$inst __addElement "$cls\::slot\::$slotname"
 340	
 341	# update the anyCounter if necessary
 342	if { $maxOccurs ne "unbounded" } {
 343		$anyslot anyCounter [incr anyCounter]
 344	}
 345	
 346	# finally set the newly created slot
 347	return [my __setSlot $slotname $slot]
 348}
 349	
 350XSDObject instproc addAnyAttribute {slotname type {value ""}} {
 351	# first check if the element actually has an <any> element:
 352	set anyAttribute [my __getSlotClass __anyAttribute]
 353	if { $anyAttribute == false } {
 354		my __error "There is no <anyAttribute> attribute to be set."
 355		return false
 356	}
 357	
 358	# check the given type:
 359	if { [string equal -length 5 $type "xsd::"] } {
 360		set type [string map {"xsd::" "::xoXSD::DataTypes::"} $type]
 361	}
 362	if { ![::xotcl::Class isclass $type] } {
 363		my __error "The given type ($type) is undefined."
 364		return false
 365	}
 366	if { ![lsearch -not [$type info heritage] "::xoXSD::DataTypes::DataType"] } {
 367		my __error "The given type ($type) doesn't seem to be a simple datatype."
 368		return false
 369	}
 370	
 371	# search for the class/instance that has the __anyAttribute slot defined:
 372	set cls [[$anyAttribute info parent] info parent]
 373	set inst ""
 374	foreach inst [my __getAllChildren -includeMyself true] {
 375		set c [$inst class]
 376		if { $c eq $cls || [lsearch [$c info heritage] $cls] != -1 } { 
 377			break
 378		}
 379	}
 380	if { $inst eq "" } { error "should not reach here. didn't find inst!" }
 381	
 382	# check for namespace restrictions:
 383	set anyslot "$cls\::slot\::__anyAttribute"
 384	set namespaces [split [$anyslot namespace] " "]
 385	set content [$type new $value]
 386	if { ![my __checkAnyNamespaceRestrictions $namespaces $inst $content] } {
 387		my __error "The attribute cannot be assigned because of namespace restrictions."
 388		return false
 389	}
 390	
 391	# dynamically create and add a new slot to the class
 392	$cls slots "::xoXSD::Slots::XMLAttribute $slotname -type $type"
 393	$inst __addAttribute "$cls\::slot\::$slotname"
 394	
 395	# finally set the newly created slot
 396	my $slotname $content
 397}
 398
 399XSDObject instproc isAssigned {slot} {
 400	return [my __slotFilled -recursive true $slot]
 401}
 402
 403XSDObject instproc . {accessor args} {
 404	if { [llength [my $accessor]] > 1 } {
 405		set dots [expr [llength [split $args .]] - 1]
 406		if { $dots < 1 && $args ne "" } {
 407			my __error "Cannot execute the function \"[string trim $args]\" because \"$accessor\" returned multiple objects."
 408			return
 409		} 
 410		if { $dots > 0 } {
 411			my __error "Cannot access \"[string trimleft $args { .}]\" because \"$accessor\" returned multiple objects."
 412		}
 413		return [my $accessor]
 414		
 415	} elseif { [my $accessor] eq "" } {
 416		my __error "The element or attribute \"$accessor\" doesn't exist."
 417		return ""
 418		
 419	} else {
 420		return [[my $accessor] {*}$args]
 421	}
 422}
 423
 424XSDObject instforward export %self marshal
 425
 426##############################################
 427#         * Various helper functions *       #
 428# Note: you shouldn't call them directly.    #
 429##############################################
 430
 431XSDObject instproc __marshalAttributes {doc root} {
 432	# iterate over all attributes
 433	foreach attribute [my __attributes] {
 434		my __marshalAttribute $doc $root $attribute
 435	}
 436	
 437	# do the same with all children
 438	foreach child [my __children] {
 439		$child __marshalAttributes $doc $root	
 440	}
 441}
 442
 443XSDObject instproc __marshalAttribute {doc root attribute} {
 444	if { ![my __slotFilled $attribute] } return
 445	
 446	set content [[my [namespace tail $attribute]] getContent]
 447	if { [$attribute text] } {
 448		$root appendChild [$doc createTextNode $content]
 449	} else {	
 450		$root setAttribute [namespace tail $attribute] $content
 451	}
 452}
 453
 454XSDObject instproc __marshalElements {doc root} {
 455	# iterate over all elements
 456	foreach element [my __elements] {
 457		my __marshalElement $doc $root $element
 458	}
 459	
 460	# do the same with all children
 461	foreach child [my __children] {
 462		$child __marshalElements $doc $root	
 463	}
 464}
 465
 466Sequence instproc __marshalElements {doc root} {
 467	foreach obj [my __sequence] {
 468		if { [string match "*::slot::*" $obj ] } {
 469			my __marshalElement $doc $root $obj
 470		} else {
 471			$obj __marshalElements $doc $root	
 472		}
 473	}
 474}
 475
 476XSDObject instproc __marshalElement {doc root element} {
 477	if { ![my __slotFilled $element] } return
 478	set name [my __getXmlElementMarshalName $element] 
 479	foreach element [my [namespace tail $element]] {
 480		set xml [$element marshal -name $name]
 481		if { $xml ne "" } {
 482			$root appendXML $xml
 483		}
 484	}
 485}
 486
 487XSDObject instproc __setXmlnsAttributes {root} {
 488	foreach element [my __elements] {
 489		set element [namespace tail $element]
 490		if { ![my __slotFilled $element] } continue
 491		
 492		set element [lindex [my $element] 0]
 493		set ns [$element __getXmlNamespace]
 494		set prefix [$element __getXmlPrefix]
 495		
 496		if { $prefix ne "" } {
 497			$root setAttribute "xmlns:$prefix" $ns
 498		}
 499	}	
 500	foreach child [my __children] {
 501		$child __setXmlnsAttributes $root
 502	}
 503}
 504	
 505XSDObject instproc __getXmlElementMarshalName { {element ""} } {
 506	if { $element eq "" } { 
 507		set element [my class] 
 508	}
 509	set name [namespace tail $element]
 510	set prefix [my __getXmlPrefix]
 511	if { $prefix ne "" } {
 512		set name "$prefix:$name"
 513	}	
 514	return $name
 515}
 516
 517XSDObject instproc __getRootNamespaceVariable {varname} {
 518	foreach c [concat [my class] [[my class] info heritage]] {
 519		regsub -all {::__choice\d+}   $c {} c
 520		regsub -all {::__sequence\d+} $c {} c
 521		set qualifiers [namespace qualifiers $c]
 522		if { $qualifiers eq "::xoXSD" } break
 523		if { [namespace eval $qualifiers info exists $varname] } {
 524			namespace upvar $qualifiers $varname var
 525			return $var
 526		}
 527	}
 528	error "shouldn't reach here"
 529}
 530
 531XSDObject instproc __getXmlNamespace {} {
 532	return [my __getRootNamespaceVariable xmlNamespace]
 533}
 534
 535XSDObject instproc __getXmlPrefix {} {
 536	return [my __getRootNamespaceVariable xmlPrefix]
 537}
 538
 539XSDObject instproc __getSlotClass { {-withChildSlots:boolean false} slot } {
 540	set slotclass [my __doGetSlotClass -withChildSlots $withChildSlots $slot]
 541	if { $slot == false } {
 542		my __error "there is no such slot: $slot"	
 543		return false
 544	} 
 545	return $slotclass
 546}
 547
 548XSDObject instproc __getSlots { {-withChildSlots:boolean false} } {
 549	if { $withChildSlots } {
 550		return [concat [my __elements] [my __attributes] [my __childslots]]
 551	} 
 552	return [concat [my __elements] [my __attributes]]
 553}
 554
 555XSDObject instproc __getLocalSlots {} {
 556	# now create a list of all slots
 557	set slots [[my class] info slots]
 558	
 559	# remember slotnames
 560	foreach slot $slots {set slotname([namespace tail $slot]) 1}
 561	
 562	# iterate over class structure
 563	set heritage [[my class] info heritage]
 564	foreach c [lsearch -inline -all -not $heritage "::xoXSD::*"] {
 565		foreach slot [$c info slots] {
 566			set key slotname([namespace tail $slot])
 567			
 568			# don't add slots which are already defined in 
 569			# more specialized classes
 570			if {[info exists $key]} continue
 571			set $key 1
 572			lappend slots $slot
 573		}
 574	}
 575	
 576	return $slots
 577}
 578
 579XSDObject instproc __getSlotType {slot} {
 580	# returns either XMLAttribute, XMLElement, XMLChild or false
 581	set slotclass [my __getSlotClass $slot]
 582	if { $slotclass == false } { return false }
 583	return [namespace tail [$slotclass class]]
 584}
 585
 586XSDObject instproc __getSlot {slot} {
 587	foreach o [my __getAllChildren -includeMyself true] {
 588		set r [$o __doGetSlot $slot]
 589		if { $r ne "false" } {
 590			return $r
 591		}
 592	}
 593	my __error "There is no such Element: $slot"
 594	return ""
 595}
 596
 597XSDObject instproc __doGetSlot {slot} {
 598	set slot [namespace tail $slot]
 599	
 600	if { ![my __slotExists $slot] || ![my exists [namespace tail $slot]] } {
 601		return false
 602	}
 603	
 604	set parent [my info parent]
 605	if { [Object isobject $parent] && [$parent class] ne "::xoXSD::CodeGenerator"} {
 606		set classname [namespace tail [my class]]
 607		set c [$parent __getSlotClass -withChildSlots true $classname]
 608	
 609		if { [$c multivalued] } {
 610			set slots [list]
 611			foreach child [$parent $classname] {
 612				if { [$child exists $slot] } {
 613					lappend slots [$child $slot]
 614				}
 615			}
 616			if { [llength $slots] == 0 } {
 617				return false
 618			}
 619			return $slots
 620		}
 621	}
 622	
 623	return [my $slot]
 624}
 625
 626XSDObject instproc __setSlot {slot value} {
 627	if { [Object isobject $value] && ![$value check] } {
 628		my __error "Cannot assign \"$value\" because it is not valid."
 629		return false
 630	}
 631	foreach o [my __getAllChildren -includeMyself true] {
 632		if { [$o __doSetSlot $slot $value] } {
 633			return true
 634		}
 635	}
 636	if { ![my __slotExists -recursive true $slot] } {
 637		my __error "There is no such Element: $slot"
 638	}
 639	return false
 640}
 641
 642XSDObject instproc __doSetSlot {slot value} {
 643	set slot [namespace tail $slot]
 644	if { ![my __slotExists $slot] } {
 645		return false
 646	}
 647	
 648	# check the choice-parents if we're allowed to set an element
 649	foreach o [my __choiceParents] {
 650		if { ![$o __isAssignmentAllowed] } {
 651			return false
 652		}
 653	}
 654	
 655	set c [my __getSlotClass $slot]
 656	if { ![Object isobject $value] } {
 657		my __error "I am expecting an Object of type [$c getType] but \"$value\" doesn't seem to be one."
 658		return false
 659	}
 660	
 661	# check if the given value-object matches the required type
 662	if { [$c type] ne [$value class] } {
 663		if { [$c type] ne [[$value class] info superclass] } {
 664			my __error "\"$slot\" has to be of type [$c getType]"
 665			return false
 666		}
 667	}
 668	
 669	# check for a simpleType's enumeration restriction
 670	set enum [list]
 671	if { [$c exists enumvalues] } {
 672		set enum [$c enumvalues]
 673	}
 674	if { [llength $enum] > 0 } {
 675		if { [lsearch -exact $enum [$value getContent]] == -1 } {
 676			my __error "\"$slot\" is not correctly formatted."
 677			return false
 678		}
 679	}
 680	
 681	# check for multivalued slots
 682	if { [$c multivalued] && [my __slotFilled $slot] } {
 683		set occurs [llength [my $slot]]
 684		set maxOccurs [$c maxOccurs]
 685		if { $maxOccurs eq "unbounded" || $occurs < $maxOccurs } {
 686			# add the slot
 687			my $slot add $value
 688			return true
 689			
 690		} else {
 691			my __error "\"$slot\" cannot be set because of a maxOccurs restriction."
 692			return false
 693		}
 694	} 
 695	
 696	# assign the slot
 697	my $slot $value
 698	
 699	# tell the choice-parents that we've set an element
 700	my __updateChoiceParents
 701	
 702	# finally return true
 703	return true
 704}
 705
 706XSDObject instproc __updateChoiceParents { } { }
 707
 708XSDChildObject instproc __updateChoiceParents {} {
 709	foreach o [my __choiceParents] {
 710		set slot [lindex [split [string range [string map [list [$o class] ""] [my class]] 2 end] "::"] 0]
 711		$o __setAssignedElement $slot
 712	}
 713}
 714	
 715Choice instproc __setAssignedElement {slot} {
 716	if { [my __assignedElement] ne "" } return
 717	my __assignedElement "[my class]::slot::$slot"
 718}
 719
 720Choice instproc __isInSameNamespace {c1 c2} { 
 721        set len [string length $c1]
 722        return [string equal -length $len $c2 $c1]
 723}
 724
 725Choice instproc __isAssignmentAllowed {} {
 726	if { [my __assignedElement] eq "" } {
 727		return true
 728	}
 729	
 730	if { [namespace tail [[my __assignedElement] class]] eq "XMLElement" } {
 731		return false
 732	}
 733	
 734	set assigned [string map {"::slot" ""} [my __assignedElement]]
 735	set caller [[self callingobject] class]
 736	
 737	return [my __isInSameNamespace $assigned $caller]
 738}
 739
 740Choice instproc __doSetSlot {slot value} {
 741	if { ![my __slotExists $slot] } {
 742		return false
 743	}
 744	
 745	if { [my __isAssignmentAllowed] } {
 746		if { [next] } {
 747			my __setAssignedElement $slot
 748			return true
 749		} else {
 750			return false
 751		}
 752	}
 753
 754	if { [my __tryCreateChild $slot $value] } {
 755		return true
 756	} 
 757	
 758	if { [my __assignedElement] eq "" || [namespace tail [[my __assignedElement] class]] eq "XMLElement" } {	
 759		my __error "Cannot assign \"$slot\" because of an XML Schema Choice restriction."
 760	} 
 761	
 762	return false
 763}
 764	
 765Sequence instproc __doSetSlot {slot value} {
 766	if { ![my __slotExists $slot] } {
 767		return false
 768	}
 769	
 770	if { [next] } {
 771		return true
 772	}
 773	
 774	if { [my __tryCreateChild $slot $value] } {
 775		return true
 776	}
 777	return false
 778}	
 779	
 780XSDChildObject instproc __tryCreateChild {slot value} {
 781	set name [namespace tail [my class]]
 782	set parent [my info parent]
 783	set c [$parent __getSlotClass -withChildSlots true $name]
 784	
 785	if { ![$c multivalued] } {
 786		return false
 787	} 
 788	
 789	set occurs [llength [$parent $name]]
 790	set maxOccurs [$c maxOccurs]
 791	if { $maxOccurs eq "unbounded" || $occurs < $maxOccurs } {
 792		set ch [eval [my class] new -childof $parent]
 793		
 794		$parent $name add $ch
 795		$parent __addChild $ch
 796		
 797		return [$ch __doSetSlot $slot $value]
 798	} 
 799
 800	return false
 801}
 802
 803XSDObject instproc __doGetSlotClass { {-withChildSlots:boolean false} slot } {
 804	set slot [namespace tail $slot]
 805	if { ![my __slotExists -withChildSlots $withChildSlots $slot] } {
 806		foreach child [my __children] {
 807			set result [$child __doGetSlotClass $slot]
 808			if { $result != false } { return $result }
 809		}
 810		return false
 811		
 812	} else {
 813		return [lsearch -inline -glob [my __getSlots -withChildSlots $withChildSlots] "*::$slot"]
 814	}
 815}
 816
 817XSDObject instproc __error {msg} {
 818	variable __quiet
 819	if { $__quiet } return
 820	puts " "
 821	puts "An ERROR occured:"
 822	puts "  o) Object:  [self]"
 823	puts "  o) Type:    [my class]"
 824	puts "  o) Proc:    [self callingproc]"
 825	puts "  o) Message: [join $msg]"
 826	puts " "
 827}
 828
 829XSDObject instproc __slotExists { {-withChildSlots:boolean false} {-recursive:boolean false} slot } {
 830	if { $recursive } {
 831		set children [my __getAllChildren -includeMyself true]
 832	} else {
 833		set children [self]
 834	}
 835	foreach o $children {
 836		if { [lsearch [$o __getSlots -withChildSlots $withChildSlots] "*::slot::[namespace tail $slot]"] != -1 } {
 837			return 1
 838		}
 839	}
 840	return 0
 841}
 842
 843XSDObject instproc __slotFilled { {-recursive:boolean false} {-exact:boolean false} slot } {
 844	if { $recursive } {
 845		set children [my __getAllChildren -includeMyself true]
 846	} else {
 847		set children [self]
 848	}
 849	
 850	foreach o $children {
 851		set name [namespace tail $slot]
 852		if { [$o exists $name] } {
 853			set occurs [llength [$o $name]]
 854			if { $exact && [namespace qualifiers [namespace qualifiers $slot]] ne [$o class] } {
 855				continue
 856			}
 857			return $occurs
 858		}
 859	}
 860	
 861	return 0
 862}
 863
 864XSDObject instproc __getAllChildren { {-includeMyself:boolean false} } {
 865	set children [my __children]
 866	foreach child [my __children] {
 867		set children [concat $children [$child __getAllChildren]]
 868	}
 869	if { $includeMyself } {
 870		set children [concat [self] $children]
 871	}
 872	return $children
 873}
 874	
 875XSDObject instproc __addElement {element} {
 876	my lappend __elements $element
 877}
 878		
 879Sequence instproc __addElement {element} {
 880	next
 881	my lappend __sequence $element
 882}	
 883	
 884XSDObject instproc __addAttribute {attribute} {
 885	my lappend __attributes $attribute
 886}
 887
 888XSDObject instproc __addChild {child} {
 889	my lappend __children $child
 890}
 891
 892Sequence instproc __addChild {child} {
 893	next
 894	my lappend __sequence $child
 895}
 896	
 897XSDObject instproc __checkAnyNamespaceRestrictions {namespaces inst value} {	
 898	if { [lsearch $namespaces "##any"] != -1 } {
 899		return true
 900		
 901	} elseif { [lsearch $namespaces "##other"] != -1 } {
 902		if { [$value __getXmlNamespace] ne [$inst __getXmlNamespace] } {
 903			return true
 904		}
 905		
 906	} elseif { [lsearch $namespaces "##targetNamespace"] != -1 } {
 907		if { [$value __getXmlNamespace] eq [$inst __getXmlNamespace] } {
 908			return true
 909		} 
 910		
 911	} elseif { [lsearch $namespaces "##local"] != -1 } {
 912		if { [$value __getXmlNamespace] eq "" } {
 913			return true
 914		} 
 915		
 916	} else {
 917		foreach ns $namespaces {
 918			if { $ns eq [$value __getXmlNamespace] } {
 919				return true
 920			}
 921		}
 922	}
 923	
 924	return false
 925}
 926
 927XSDChildObject instproc __getParentSlot {} {
 928	set parent [[my info parent] class]
 929	set name [namespace tail [my class]]
 930	
 931	foreach c [concat $parent [$parent info heritage]] {
 932		set s "$c\::slot\::$name"
 933		if { [Object isobject $s] && [namespace tail [$s class]] eq "XMLChild"} {
 934			return $s
 935		}
 936	}
 937	error "shouldn't reach here."
 938}
 939
 940XSDChildObject instproc __checkMinOccursSelf {} {
 941	set slot [my __getParentSlot]
 942	set name [namespace tail [my class]]
 943	
 944	if { [$slot minOccurs] > 0 } {
 945		if { [llength [[my info parent] $name]] < [$slot minOccurs] } {
 946			my __error "I need [$slot minOccurs] instances of the element: $name (type: [$slot getType])"
 947			return 0
 948		}
 949	} 
 950	return 1
 951}
 952
 953XSDObject instproc __checkMinOccurs {slot} {
 954	set name [namespace tail $slot]
 955	set validity 1
 956	if { [$slot minOccurs] > 0 } {
 957		if { ![my __slotFilled $slot] } {
 958			set validity 0
 959			my __error "Missing element: $name (type: [$slot getType])"
 960			
 961		} elseif { [llength [my $name]] < [$slot minOccurs] } {
 962			set validity 0
 963			my __error "I need [$slot minOccurs] instances of the element: $name (type: [$slot getType])"
 964		}	
 965	}	
 966	return $validity
 967}
 968
 969XSDObject instproc __makeTable {tableheader headers content} {
 970	set width [list]
 971	foreach header $headers {
 972		lappend width [string length $header]
 973	}
 974	foreach line $content {
 975		for {set i 0} {$i < [llength $line]} {incr i} {
 976			set colMax 0
 977			foreach colLine [lindex $line $i] {
 978				set colMax [expr max($colMax, [string length $colLine])]	
 979			}
 980			lset width $i [expr max($colMax, [lindex $width $i])]
 981		}
 982	}
 983	
 984	set sep "+"
 985	set lw 0
 986	foreach w $width {
 987		incr lw $w
 988		append sep "-[string repeat - $w]-+"
 989	}
 990	set o "+[string repeat - [expr $lw + 3 * [llength $headers] - 1]]+\n"
 991	append o "| [format "%-*s | " [expr $lw + 2 * [llength $headers]] $tableheader]\n"
 992	
 993	append o "$sep\n[my __makeTableRow $width $headers]$sep\n"
 994	foreach line $content {
 995		set colLinesMax 1
 996		foreach colLines $line {
 997			set colLinesMax [expr max($colLinesMax, [llength $colLines])]
 998		}
 999		set content [list]
1000		for {set i 0} {$i < $colLinesMax} {incr i} {
1001			set content [list]
1002			for {set j 0} {$j < [llength $line]} {incr j} {
1003				lappend content [lindex [lindex $line $j] $i]
1004			}
1005			append o [my __makeTableRow $width $content]
1006		}
1007		append o "$sep\n"
1008	}
1009	return $o
1010}
1011
1012XSDObject instproc __makeTableRow {width content} {
1013	set line "| "
1014	for {set i 0} {$i < [llength $content]} {incr i} {
1015		append line [format "%-*s | " [lindex $width $i] [lindex $content $i]]
1016	}
1017	return "$line\n"
1018}
1019
1020XSDObject instproc unknown {cmd args} {
1021	set args [join $args]
1022	
1023	#read slot
1024	if { $args eq "" } {
1025		return [my __getSlot $cmd]	
1026	}
1027	
1028	#set slot...
1029	return [my __setSlot $cmd [my __lookupObject $args]]
1030}
1031
1032XSDObject instproc __lookupObject {name} {
1033	set i 1
1034	set ns ""
1035	while { ![Object isobject "$ns\::$name"] } {
1036		# get the caller's namespace:
1037		if { [catch { set ns [uplevel [incr i] namespace current] } err] } {
1038			return $name
1039		}
1040	}
1041	return "$ns\::$name"
1042}
1043
1044XSDObject instproc __namespaceQualifiers {ns {depth 1}} {
1045	while { $depth > 0 } {
1046		set ns [namespace qualifiers $ns]
1047		incr depth -1
1048	}
1049	return $ns
1050}
1051
1052}
1053