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