1# doctoc.tcl -- 2# 3# Implementation of doctoc objects for Tcl. v2. 4# 5# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net> 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: container.tcl,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $ 11 12# Each object manages one table of contents, with methods to add and 13# remove entries and divisions, singly, or in bulk. The bulk methods 14# accept various forms of textual serializations, among them text 15# using the doctoc markup language. 16 17# ### ### ### ######### ######### ######### 18## Requisites 19 20package require Tcl 8.4 21package require doctools::toc::structure 22package require snit 23package require struct::tree 24 25# ### ### ### ######### ######### ######### 26## API 27 28snit::type ::doctools::toc { 29 30 # Concepts: 31 # - A table of contents consists of an ordered set of elements, 32 # references and divisions. 33 # - Both type of elements within the table are identified by their 34 # label. 35 # - A reference has two additional pieces of information, 36 # the id of the document it references, and a textual description. 37 # - A division may have the id of a document. 38 # - The main data of a division is an ordered set of elements, 39 # references and divisions. 40 # - Both type of elements within the division are identified by 41 # their label. 42 # - The definitions above define a tree of elements, with 43 # references as leafs, and divisions as the inner nodes. 44 # - Regarding identification, the full label of each element is 45 # the list of per-node labels on the path from the root of the 46 # tree to the element itself. 47 48 # ### ### ### ######### ######### ######### 49 ## Options 50 51 ## None 52 53 # ### ### ### ######### ######### ######### 54 ## Methods 55 56 constructor {} { 57 install mytree using struct::tree ${selfns}::T 58 # Root is a fake division 59 set myroot [$mytree rootname] 60 $mytree set $myroot type division 61 $mytree set $myroot label {} 62 $mytree set $myroot labelindex {} 63 return 64 } 65 66 # Default destructor. 67 68 # ### ### ### ######### ######### ######### 69 70 method invalidate {} { 71 array unset mytoc * 72 return 73 } 74 75 # ### ### ### ######### ######### ######### 76 77 method title {{text {}}} { 78 if {[llength [info level 0]] == 6} { 79 set mytitle $text 80 } 81 return $mytitle 82 } 83 84 method label {{text {}}} { 85 if {[llength [info level 0]] == 6} { 86 set mylabel $text 87 $mytree set $myroot label $text 88 } 89 return $mylabel 90 } 91 92 method exporter {{object {}}} { 93 # TODO :: unlink/link change notification callbacks on the 94 # config/include components so that we can invalidate our 95 # cache when the settings change. 96 97 if {[llength [info level 0]] == 6} { 98 set myexporter $object 99 } 100 return $myexporter 101 } 102 103 method importer {{object {}}} { 104 if {[llength [info level 0]] == 6} { 105 set myimporter $object 106 } 107 return $myimporter 108 } 109 110 # ### ### ### ######### ######### ######### 111 ## Direct manipulation of the table of contents. 112 113 method {+ reference} {pid label docid desc} { 114 CheckDiv $pid 115 if {$docid eq {}} { 116 return -code error "Illegal empty document reference for reference entry" 117 } 118 119 array set l [$mytree get $pid labelindex] 120 if {[info exists l($label)]} { 121 return -code error "Redefinition of label '$label' in '[$self full-label $pid]'" 122 } 123 124 set new [$mytree insert $pid end] 125 set l($label) $new 126 $mytree set $pid labelindex [array get l] 127 128 $mytree set $new type reference 129 $mytree set $new label $label 130 $mytree set $new document $docid 131 $mytree set $new description $desc 132 133 array unset mytoc * 134 return $new 135 } 136 137 method {+ division} {pid label {docid {}}} { 138 CheckDiv $pid 139 140 array set l [$mytree get $pid labelindex] 141 if {[info exists l($label)]} { 142 return -code error "Redefinition of label '$label' in '[$self full-label $pid]'" 143 } 144 145 set new [$mytree insert $pid end] 146 set l($label) $new 147 $mytree set $pid labelindex [array get l] 148 149 $mytree set $new type division 150 $mytree set $new label $label 151 if {$docid ne {}} { 152 $mytree set $new document $docid 153 } 154 $mytree set $new labelindex {} 155 156 array unset mytoc * 157 return $new 158 } 159 160 method remove {id} { 161 Check $id 162 if {$id eq $myroot} { 163 return -code error {Unable to remove root} 164 } 165 set pid [$mytree parent $id] 166 set label [$mytree get $id label] 167 168 array set l [$mytree get $pid labelindex] 169 unset l($label) 170 $mytree set $pid labelindex [array get l] 171 $mytree delete $id 172 173 array unset mytoc * 174 return 175 } 176 177 # ### ### ### ######### ######### ######### 178 179 method up {id} { 180 Check $id 181 return [$mytree parent $id] 182 } 183 184 method next {id} { 185 Check $id 186 set n [$mytree next $id] 187 if {$n eq {}} { set n [$mytree parent $id] } 188 return $n 189 } 190 191 method prev {id} { 192 Check $id 193 set n [$mytree previous $id] 194 if {$n eq {}} { set n [$mytree parent $id] } 195 return $n 196 } 197 198 method child {id label args} { 199 CheckDiv $id 200 # Find the id of the element with the given labels, in the 201 # parent element id. 202 foreach label [linsert $args 0 $label] { 203 array set l [$mytree get $id labelindex] 204 if {![info exists l($label)]} { 205 return -code error "Bad label '$label' in '[$self full-label $id]'" 206 } 207 set id $l($label) 208 unset l 209 } 210 return $id 211 } 212 213 method element {args} { 214 if {![llength $args]} { return $myroot } 215 # 8.5: $self child $myroot {*}$args 216 return [eval [linsert $args 0 $self child $myroot]] 217 } 218 219 method children {id} { 220 CheckDiv $id 221 return [$mytree children $id] 222 } 223 224 # ### ### ### ######### ######### ######### 225 226 method type {id} { 227 Check $id 228 return [$mytree get $id type] 229 } 230 231 method full-label {id} { 232 Check $id 233 set result {} 234 foreach node [struct::list reverse [lrange [$mytree ancestors $id] 0 end-1]] { 235 lappend result [$mytree get $node label] 236 } 237 lappend result [$mytree get $id label] 238 239 return $result 240 } 241 242 method elabel {id {newlabel {}}} { 243 Check $id 244 set thelabel [$mytree get $id label] 245 if { 246 ([llength [info level 0]] == 7) && 247 ($newlabel ne $thelabel) 248 } { 249 # Handle only calls which change the label 250 251 set parent [$mytree parent $id] 252 array set l [$mytree get $parent labelindex] 253 254 if {[info exists l($newlabel)]} { 255 return -code error "Redefinition of label '$newlabel' in '[$self full-label $parent]'" 256 } 257 258 # Copy node information and re-label. 259 set l($newlabel) $l($thelabel) 260 unset l($thelabel) 261 $mytree set $id label $newlabel 262 $mytree set $parent labelindex [array get l] 263 264 if {$id eq $myroot} { 265 set mylabel $newlabel 266 } 267 268 set thelabel $newlabel 269 } 270 return $thelabel 271 } 272 273 method description {id {newdesc {}}} { 274 Check $id 275 if {[$mytree get $id type] eq "division"} { 276 return -code error "Divisions have no description" 277 } 278 set thedescription [$mytree get $id description] 279 if { 280 ([llength [info level 0]] == 7) && 281 ($newdesc ne $thedescription) 282 } { 283 # Handle only calls which change the description 284 $mytree set $id description $newdesc 285 286 set thedescription $newdesc 287 } 288 return $thedescription 289 } 290 291 method document {id {newdocid {}}} { 292 Check $id 293 set thedocid {} 294 catch { 295 set thedocid [$mytree get $id document] 296 } 297 if { 298 ([llength [info level 0]] == 7) && 299 ($newdocid ne $thedocid) 300 } { 301 # Handle only calls which change the document 302 if {$newdocid eq {}} { 303 if {[$mytree get $id type] eq "division"} { 304 $mytree unset $id document 305 } else { 306 return -code error "Illegal to unset document reference in reference entry" 307 } 308 } else { 309 $mytree set $id document $newdocid 310 } 311 set thedocid $newdocid 312 } 313 return $thedocid 314 } 315 316 # ### ### ### ######### ######### ######### 317 ## Public methods. Bulk loading and merging. 318 319 method {deserialize =} {data {format {}}} { 320 # Default format is the regular toc serialization 321 if {$format eq {}} { 322 set format serial 323 } 324 325 if {$format ne "serial"} { 326 set data [$self Import $format $data] 327 # doctools::toc::structure verify-as-canonical $data 328 # ImportSerial verifies. 329 } 330 331 $self ImportSerial $data 332 return 333 } 334 335 method {deserialize +=} {data {format {}}} { 336 # Default format is the regular toc serialization 337 if {$format eq {}} { 338 set format serial 339 } 340 341 if {$format ne "serial"} { 342 set data [$self Import $format $data] 343 # doctools::toc::structure verify-as-canonical $data 344 # merge or ImportSerial verify the structure. 345 } 346 347 set data [doctools::toc::structure merge [$self serialize] $data] 348 # doctools::toc::structure verify-as-canonical $data 349 # ImportSerial verifies. 350 351 $self ImportSerial $data 352 return 353 } 354 355 # ### ### ### ######### ######### ######### 356 357 method serialize {{format {}}} { 358 # Default format is the regular toc serialization 359 if {$format eq {}} { 360 set format serial 361 } 362 363 # First check the cache for a remebered representation of the 364 # toc for the chosen format, and return it, if such is known. 365 366 if {[info exists mytoc($format)]} { 367 return $mytoc($format) 368 } 369 370 # If there is no cached representation we have to generate it 371 # from it from our internal representation. 372 373 if {$format eq "serial"} { 374 return [$self GenerateSerial] 375 } else { 376 return [$self Generate $format] 377 } 378 379 return -code error "Internal error, reached unreachable location" 380 } 381 382 # ### ### ### ######### ######### ######### 383 ## Internal methods 384 385 proc Check {id} { 386 upvar 1 mytree mytree 387 if {![$mytree exists $id]} { 388 return -code error "Bad toc element handle '$id'" 389 } 390 return 391 } 392 393 proc CheckDiv {id} { 394 upvar 1 mytree mytree 395 Check $id 396 if {[$mytree get $id type] ne "division"} { 397 return -code error "toc element handle '$id' does not refer to a division" 398 } 399 } 400 401 method GenerateSerial {} { 402 # We can generate the list serialization easily from the 403 # internal representation. 404 405 # Construct result 406 set serial [list doctools::toc \ 407 [list \ 408 items [$self GenerateDivision $myroot] \ 409 label $mylabel \ 410 title $mytitle]] 411 412 # This is just present to assert that the code above creates 413 # correct serializations. 414 doctools::toc::structure verify-as-canonical $serial 415 416 set mytoc(serial) $serial 417 return $serial 418 } 419 420 method GenerateDivision {root} { 421 upvar 1 mytree mytree 422 set div {} 423 foreach id [$mytree children $root] { 424 set etype [$mytree get $id type] 425 set edata {} 426 switch -exact -- $etype { 427 reference { 428 lappend edata \ 429 desc [$mytree get $id description] \ 430 id [$mytree get $id document] \ 431 label [$mytree get $id label] 432 } 433 division { 434 if {[$mytree keyexists $id document]} { 435 lappend edata id [$mytree get $id document] 436 } 437 lappend edata \ 438 items [$self GenerateDivision $id] \ 439 label [$mytree get $id label] 440 } 441 } 442 lappend div [list $etype $edata] 443 } 444 return $div 445 } 446 447 method Generate {format} { 448 if {$myexporter eq {}} { 449 return -code error "Unable to export from \"$format\", no exporter configured" 450 } 451 set res [$myexporter export object $self $format] 452 set mytoc($format) $res 453 return $res 454 } 455 456 method ImportSerial {serial} { 457 doctools::toc::structure verify $serial iscanonical 458 459 # Kill existing content 460 foreach id [$mytree children $myroot] { 461 $mytree delete $id 462 } 463 464 # Unpack the serialization. 465 array set toc $serial 466 array set toc $toc(doctools::toc) 467 unset toc(doctools::toc) 468 469 # We are setting the relevant variables directly instead of 470 # going through the accessor methods. 471 472 set mytitle $toc(title) 473 set mylabel $toc(label) 474 475 $self ImportDivision $toc(items) $myroot 476 477 # Extend cache (only if canonical, as we return only canonical 478 # data). 479 if {$iscanonical} { 480 set mytoc(serial) $serial 481 } 482 return 483 } 484 485 method ImportDivision {items root} { 486 foreach element $items { 487 foreach {etype edata} $element break 488 #struct::list assign $element etype edata 489 array set toc $edata 490 switch -exact -- $etype { 491 reference { 492 $self + reference $root \ 493 $toc(label) $toc(id) $toc(desc) 494 } 495 division { 496 if {[info exists toc(id)]} { 497 set div [$self + division $root $toc(label) $toc(id)] 498 } else { 499 set div [$self + division $root $toc(label)] 500 } 501 $self ImportDivision $toc(items) $div 502 } 503 } 504 unset toc 505 } 506 return 507 } 508 509 method Import {format data} { 510 if {$myimporter eq {}} { 511 return -code error "Unable to import from \"$format\", no importer configured" 512 } 513 514 return [$myimporter import text $data $format] 515 } 516 517 # ### ### ### ######### ######### ######### 518 ## State 519 520 # References to export/import managers extending the 521 # (de)serialization abilities of the table of contents. 522 variable myexporter {} 523 variable myimporter {} 524 525 # Internal representation of the table of contents. 526 527 variable mytitle {} ; # 528 variable mylabel {} ; # 529 variable mytree {} ; # Tree object holding the toc. 530 variable myroot {} ; # Name of the tree root node. 531 532 # Array serving as cache holding alternative representations of 533 # the toc generated via 'serialize', i.e. data export. 534 535 variable mytoc -array {} 536 537 ## 538 # ### ### ### ######### ######### ######### 539} 540 541# ### ### ### ######### ######### ######### 542## Ready 543 544package provide doctools::toc 2 545return 546