1## 2## This is the file `docstrip_util.tcl', 3## generated with the SAK utility 4## (sak docstrip/regen). 5## 6## The original source files were: 7## 8## tcldocstrip.dtx (with options: `utilpkg') 9## 10## In other words: 11## ************************************** 12## * This Source is not the True Source * 13## ************************************** 14## the true source is the file from which this one was generated. 15## 16package require Tcl 8.4 17package require docstrip 1.2 18package provide docstrip::util 1.2 19namespace eval docstrip::util { 20 namespace import [namespace parent]::extract 21 namespace export ddt2man guard patch thefile 22} 23proc docstrip::util::ddt2man {text} { 24 set wascode 0 25 set verbatim 0 26 set res "" 27 foreach line [split $text \n] { 28 if {$verbatim} then { 29 if {$line eq $endverbline} then { 30 set verbatim 0 31 } else { 32 append res [string map {[ [lb] ] [rb]} $line] \n 33 } 34 } else { 35 switch -glob -- $line %%* { 36 if {$wacode} then { 37 append res {[example_end]} \n 38 set wascode 0 39 } 40 append res [string range $line 2 end] \n 41 } %<<* { 42 if {!$wascode} then { 43 append res {[example_begin]} \n 44 set wascode 1 45 } 46 set endverbline "%[string range $line 3 end]" 47 set verbatim 1 48 } %<* { 49 if {!$wascode} then { 50 append res {[example_begin]} \n 51 set wascode 1 52 } 53 set guard "" 54 regexp -- {(^%<[^>]*>)(.*)$} $line "" guard line 55 append res \[ [list emph $guard] \]\ 56 [string map {[ [lb] ] [rb]} $line] \n 57 } %* { 58 if {$wascode} then { 59 append res {[example_end]} \n 60 set wascode 0 61 } 62 append res [string range $line 1 end] \n 63 } {\\endinput} { 64 break 65 } "" { 66 append res \n 67 } default { 68 if {!$wascode} then { 69 append res {[example_begin]} \n 70 set wascode 1 71 } 72 append res [string map {[ [lb] ] [rb]} $line] \n 73 } 74 } 75 } 76 if {$wascode} then {append res {[example_end]} \n} 77 return $res 78} 79proc docstrip::util::guards {subcmd text} { 80 set verbatim 0 81 set lineno 1 82 set badL {} 83 foreach line [split $text \n] { 84 if {$verbatim} then { 85 if {$line eq $endverbline} then {set verbatim 0} 86 } else { 87 switch -glob -- $line %<<* { 88 set endverbline "%[string range $line 3 end]" 89 set verbatim 1 90 } %<* { 91 if {![ 92 regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\ 93 modifier expression line 94 ]} then { 95 lappend badL $lineno $line 96 } else { 97 if {$modifier eq ""} then {set modifier " "} 98 append E($expression) $modifier 99 } 100 } 101 } 102 incr lineno 103 } 104 if {$subcmd eq "rotten"} then {return $badL} 105 switch -- $subcmd "exprmods" { 106 return [array get E] 107 } "expressions" { 108 return [array names E] 109 } "exprerr" { 110 set res {} 111 foreach expr [array names E] { 112 regsub -all {[^()!,|&]+} $expr 0 e 113 regsub -all {,} $e {|} e 114 if {[catch {expr $e}]} then {lappend res $expr} 115 } 116 return $res 117 } 118 foreach name [array names E] { 119 set E($name) [string length $E($name)] 120 } 121 if {$subcmd eq "exprcounts"} then {return [array get E]} 122 foreach expr [array names E] { 123 foreach term [split $expr "()!,|&"] { 124 if {$term eq ""} then {continue} 125 if {![info exists T($term)]} then {set T($term) 0} 126 incr T($term) $E($expr) 127 } 128 } 129 switch -- $subcmd "counts" { 130 return [array get T] 131 } "names" { 132 return [array names T] 133 } default { 134 error "Unknown subcommand '$subcmd', must be one of:\ 135 counts, exprcounts, expressions, exprmods, names, rotten" 136 } 137} 138proc docstrip::util::patch {sourcevar termL fromtext diff args} { 139 upvar 1 $sourcevar SL 140 array set O {-trimlines 1 -matching exact} 141 array set O $args 142 set cmd [list extract [join $SL \n] $termL -annotate 2] 143 foreach opt {-metaprefix -trimlines} { 144 if {[info exists O($opt)]} then {lappend cmd $opt $O($opt)} 145 } 146 set EL [split [eval $cmd] \n] 147 lset EL end \n 148 set ptr 0 149 set lineno 1 150 set FL [list {}] 151 foreach line [split $fromtext \n] { 152 lappend FL $line 153 if {$O(-trimlines)} then {set line [string trimright $line " "]} 154 if {$line eq [lindex $EL $ptr]} then { 155 set lift($lineno) [lindex $EL [incr ptr]] 156 lset lift($lineno) 0 [expr { [lindex $EL [incr ptr]] - 1 }] 157 incr ptr 158 } 159 incr lineno 160 } 161 if {![array size lift]} then { 162 return -code error "The extract did not match any part of the\ 163 fromtext. Check the list of terminals and the options" 164 } 165 set RL [list] 166 set log [list] 167 foreach hunk [lsort -decreasing -integer -index 0 $diff] { 168 set replL [list] 169 set l1 [lindex $hunk 0] 170 set repl {0 -1} 171 set matches 1 172 foreach {type line} [lindex $hunk 4] { 173 switch -glob -- $type {[0-]} { 174 switch -- $O(-matching) "exact" { 175 if {[lindex $FL $l1] ne $line} then {set matches 0} 176 } "nonspace" { 177 if {[regsub -all -- {\s} $line {}] ne\ 178 [regsub -all -- {\s} [lindex $FL $l1] {}]} then { 179 set matches 0 180 } 181 } "anyspace" { 182 if {[regsub -all -- {\s+} $line { }] ne\ 183 [regsub -all -- {\s+} [lindex $FL $l1] { }]} then { 184 set matches 0 185 } 186 } 187 } 188 switch -- $type synch { 189 if {[llength $repl]>2 ||\ 190 [lindex $repl 1]-[lindex $repl 0]>=0} then { 191 lappend replL $repl 192 } 193 set repl [list $l1 [expr {$l1-1}]] 194 } + { 195 lappend repl $line 196 } - { 197 lset repl 1 $l1 198 incr l1 199 } 0 { 200 if {[llength $repl]>2 ||\ 201 [lindex $repl 1]-[lindex $repl 0]>=0} then { 202 lappend replL $repl 203 set repl {0 -1} 204 } 205 lset repl 1 $l1 206 incr l1 207 lset repl 0 $l1 208 } 209 } 210 if {[llength $repl]>2 || [lindex $repl 1]-[lindex $repl 0]>=0}\ 211 then {lappend replL $repl} 212 if {$matches} then { 213 lappend hunk [lsort -decreasing -integer -index 0 $replL] 214 lappend RL $hunk 215 } else { 216 lappend hunk "(-- did not match fromtext --)" 217 lappend log $hunk 218 } 219 } 220 foreach hunk $RL { 221 set applied 0 222 set misapplied 0 223 foreach repl [lindex $hunk 5] { 224 unset -nocomplain from to 225 for {set n [lindex $repl 1]} {$n>=[lindex $repl 0]}\ 226 {incr n -1} { 227 if {![info exists lift($n)]} then { 228 incr misapplied 229 continue 230 } elseif {![info exists from]} then { 231 set to [lindex $lift($n) 0] 232 set from $to 233 } elseif {[lindex $lift($n) 0] == $from-1} then { 234 set from [lindex $lift($n) 0] 235 } else { 236 set SL [lreplace $SL $from $to] 237 set to [lindex $lift($n) 0] 238 set from $to 239 } 240 incr applied 241 set n0 $n 242 } 243 if {[info exists from]} then { 244 set sprefix [lindex $lift($n0) 1] 245 set eprefix [lindex $lift($n0) 2] 246 } elseif {[info exists lift([lindex $repl 0])]} then { 247 foreach {from sprefix eprefix} $lift([lindex $repl 0])\ 248 break 249 set to [expr {$from-1}] 250 } else { 251 incr misapplied [llength [lrange $repl 2 end]] 252 continue 253 } 254 set eplen [string length $eprefix] 255 set epend [expr {$eplen-1}] 256 set cmd [list lreplace $SL $from $to] 257 foreach line [lrange $repl 2 end] { 258 if {$eprefix eq [string range $line 0 $epend]} then { 259 lappend cmd "$sprefix[string range $line $eplen end]" 260 } else { 261 lappend cmd $line 262 } 263 incr applied 264 } 265 set SL [eval $cmd] 266 } 267 if {$misapplied>0} then { 268 if {$applied>0} then { 269 lset hunk 5 "(-- was partially applied --)" 270 } else { 271 lset hunk 5 "(not applied)" 272 } 273 lappend log $hunk 274 } 275 } 276 set res "" 277 foreach hunk [lsort -index 0 -integer $log] { 278 foreach {start1 end1 start2 end2 lines msg} $hunk break 279 append res [format "@@ -%d,%d +%d,%d @@ %s\n"\ 280 $start1 [expr {$end1-$start1+1}]\ 281 $start2 [expr {$end2-$start2+1}] $msg] 282 foreach {type line} $lines { 283 switch -- $type 0 { 284 append res " " $line \n 285 } - - + { 286 append res $type $line \n 287 } 288 } 289 } 290 return $res 291} 292proc docstrip::util::thefile {fname args} { 293 set F [open $fname r] 294 if {[llength $args]} then { 295 if {[set code [ 296 catch {eval [linsert $args 0 fconfigure $F]} res 297 ]]} then { 298 close $F 299 return -code $code -errorinfo $::errorInfo -errorcode\ 300 $::errorCode 301 } 302 } 303 catch {read $F} res 304 close $F 305 return $res 306} 307proc docstrip::util::import_unidiff {text {warnvar ""}} { 308 if {$warnvar ne ""} then {upvar 1 $warnvar warning} 309 set inheader 1 310 set res [list] 311 set lines [list] 312 set end2 "not an integer" 313 foreach line [split $text \n] { 314 if {$inheader && [regexp {^(---|\+\+\+)} $line]}\ 315 then {continue} 316 switch -glob -- $line { *} { 317 lappend lines 0 [string range $line 1 end] 318 } {+*} { 319 lappend lines + [string range $line 1 end] 320 } {-*} { 321 lappend lines - [string range $line 1 end] 322 } @@* { 323 if {[string is integer $end2]} then { 324 lappend res [list $start1 $end1 $start2 $end2 $lines] 325 } 326 set len2 [set len1 ,1] 327 if {[ 328 regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@}\ 329 $line -> start1 len1 start2 len2 330 ] && [scan "$start1 $len1,1" {%d ,%d} start1 len1]==2 &&\ 331 [scan "$start2 $len2,1" {%d ,%d} start2 len2]==2 332 } then { 333 set end1 [expr {$start1+$len1-1}] 334 set end2 [expr {$start2+$len2-1}] 335 set inheader 0 336 } else { 337 set end2 "not an integer" 338 append warning "Could not parse hunk header: " $line \n 339 } 340 set lines [list] 341 } "" { 342 } default { 343 append warning "Could not parse line: " $line \n 344 } 345 } 346 if {[string is integer $end2]} then { 347 lappend res [list $start1 $end1 $start2 $end2 $lines] 348 } 349 return $res 350} 351## 352## 353## End of file `docstrip_util.tcl'.