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