| 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 | ## |
|---|
| 16 | package require Tcl 8.4 |
|---|
| 17 | package require docstrip 1.2 |
|---|
| 18 | package provide docstrip::util 1.2 |
|---|
| 19 | namespace eval docstrip::util { |
|---|
| 20 | namespace import [namespace parent]::extract |
|---|
| 21 | namespace export ddt2man guard patch thefile |
|---|
| 22 | } |
|---|
| 23 | proc 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 | } |
|---|
| 79 | proc 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 | } |
|---|
| 138 | proc 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 | } |
|---|
| 292 | proc 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 | } |
|---|
| 307 | proc 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'. |
|---|
