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'.