1# text_write.tcl --
2#
3#	Commands for the generation of TEXT
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: text_write.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
11
12# ### ### ### ######### ######### #########
13## Requisites
14
15package require Tcl 8.5
16package require textutil::adjust
17
18namespace eval ::text::write {
19    namespace export \
20	reset clear field fieldl fieldr /line prefix indent \
21	store recall undef undo get getl maxlen fieldsep \
22	push pop pop-append copy move clear-block exists
23
24
25    namespace ensemble create
26}
27
28# ### ### ### ######### ######### #########
29## API.
30
31proc ::text::write::reset {} {
32    # Reset state, fully (clear line and block buffers, , stack, set
33    # the default field separator, and flush the named blocks)
34    variable currentline    {}
35    variable currentblock   {}
36    variable stack          {}
37    variable fieldseparator { }
38    variable blocks
39    array unset blocks *
40    return
41}
42
43proc ::text::write::clear {} {
44    # Reset state (clear line and block buffers, stack, and set the
45    # default field separator)
46    variable currentline    {}
47    variable currentblock   {}
48    variable stack          {}
49    variable fieldseparator { }
50    return
51}
52
53proc ::text::write::field {args} {
54    # Extend line buffer, at end.
55    variable currentline
56    lappend  currentline {*}$args
57    return
58}
59
60proc ::text::write::fieldl {fieldlength text} {
61    # As field, but a text left-aligned in a field of given length.
62    field [format %-${fieldlength}s $text]
63    return
64}
65
66proc ::text::write::fieldr {fieldlength text} {
67    # As field, but a text right-aligned in a field of given length.
68    field [format %${fieldlength}s $text]
69    return
70}
71
72proc ::text::write::fieldsep {char} {
73    # Set field separator for '/line'
74    variable fieldseparator $char
75    return
76}
77
78proc ::text::write::get {} {
79    # Return text of current block.
80    variable currentblock
81    set res $currentblock
82    reset
83    return [join $res \n]
84}
85
86proc ::text::write::getl {} {
87    # As get, but retrieve the raw list of lines.
88    variable currentblock
89    set res $currentblock
90    reset
91    return $res
92}
93
94proc ::text::write::/line {} {
95    # Commit current line to current block (added at end)
96    variable currentline
97    variable currentblock
98    variable fieldseparator
99    lappend  currentblock [string trimright [join $currentline $fieldseparator]]
100    set      currentline {}
101    return
102}
103
104proc ::text::write::undo {} {
105    # Remove last line from current block.
106    variable currentblock
107    set      currentblock [lreplace $currentblock end end]
108    return
109}
110
111proc ::text::write::prefix {prefix {n 0}} {
112    # Indent current block using the prefix text, skipping the first n lines
113    variable currentblock
114    set currentblock \
115	[split \
116	     [textutil::adjust::indent \
117		  [join $currentblock \n] \
118		  $prefix $n] \
119	     \n]
120    return
121}
122
123proc ::text::write::indent {k {n 0}} {
124    # Indent current block by k spaces, skipping the first n lines
125    variable currentblock
126    set currentblock \
127	[split \
128	     [textutil::adjust::indent \
129		  [join $currentblock \n] \
130		  [string repeat { } $k] $n] \
131	     \n]
132    return
133}
134
135
136proc ::text::write::store {name} {
137    # Save current block and under a name. /store
138    variable currentblock
139    variable blocks
140    set blocks($name) $currentblock
141    return
142}
143
144proc ::text::write::recall {name} {
145    # Append named block to current block. /recall
146    variable currentblock
147    variable blocks
148    lappend currentblock {*}$blocks($name)
149    return
150}
151
152proc ::text::write::undef {name} {
153    # Remove the specified block from memory
154    variable blocks
155    unset    blocks($name)
156    return
157}
158
159proc ::text::write::exists {name} {
160    # Remove the specified block from memory
161    variable blocks
162    return [info exists blocks($name)]
163}
164
165proc ::text::write::copy {src dst} {
166    # Copy named block to other named block, overwriting it.
167    variable blocks
168    set blocks($dst) $blocks($src)
169    return
170}
171
172proc ::text::write::clear-block {name} {
173    # Clear the named block.
174    variable blocks
175    set blocks($name) ""
176    return
177}
178
179proc ::text::write::move {src dst} {
180    # Move named block to other named block, overwriting it.
181    variable blocks
182    set   blocks($dst) $blocks($src)
183    unset blocks($src)
184    return
185}
186
187proc ::text::write::push {} {
188    # Suspend current block.
189    variable currentblock
190    variable stack
191    lappend stack $currentblock
192    return
193}
194
195proc ::text::write::pop {} {
196    # Recall the last suspended block, replace current block.
197    variable currentblock
198    variable stack
199    set currentblock [lindex $stack end]
200    set stack [lrange $stack 0 end-1]
201    return
202}
203
204proc ::text::write::pop-append {} {
205    # Recall the last suspended block, add to the current block.
206    variable currentblock
207    variable stack
208    lappend currentblock {*}[lindex $stack end]
209    set stack [lrange $stack 0 end-1]
210    return
211}
212
213proc ::text::write::maxlen {list} {
214    # Find the max length of the strings in the list.
215
216    set lengths 0 ; # This will be the max if the list is empty, and
217		    # prevents the mathfunc from throwing errors for
218		    # that case.
219
220    foreach str $list {
221	lappend lengths [::string length $str]
222    }
223
224    return [tcl::mathfunc::max {*}$lengths]
225}
226
227# ### ### ### ######### ######### #########
228## Internals.
229
230# ### ### ### ######### ######### #########
231
232namespace eval ::text::write {
233    # State of the writer.
234
235    variable currentline    {}  ; # List of text fragments which make
236				  # up the current line.
237    variable currentblock   {}  ; # List of lines which make up the
238				  # current block.
239    variable  blocks            ; # Set of named blocks.
240    array set blocks        {}  ; #
241    variable fieldseparator { } ; # Current field separator.
242    variable stack          {}  ; # Stack of suspended blocks.
243}
244
245# ### ### ### ######### ######### #########
246## Ready
247
248package provide text::write 1
249return
250