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