# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package docstrip::util 1.3
# Meta as::build::date 2015-05-25
# Meta as::origin      http://sourceforge.net/projects/tcllib
# Meta category        Literate programming tool
# Meta description     Docstrip-related utilities
# Meta license         BSD
# Meta platform        tcl
# Meta require         {Tcl 8.4}
# Meta require         {docstrip 1.2}
# Meta subject         patch {Tcl module} {package indexing} catalogue
# Meta subject         {literate programming} doctools docstrip diff source
# Meta subject         .ddt documentation module
# Meta summary         docstrip_util
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.4
package require docstrip 1.2

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide docstrip::util 1.3

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
## 
## This is the file `docstrip_util.tcl',
## generated with the SAK utility
## (sak docstrip/regen).
## 
## The original source files were:
## 
## tcldocstrip.dtx  (with options: `utilpkg')
## 
## In other words:
## **************************************
## * This Source is not the True Source *
## **************************************
## the true source is the file from which this one was generated.
##
package require Tcl 8.4
package require docstrip 1.2
package provide docstrip::util 1.3
namespace eval docstrip::util {
   namespace export ddt2man guard patch thefile\
     packages_provided index_from_catalogue modules_from_catalogue\
     classical_preamble classical_postamble
}
namespace eval docstrip::util {
   namespace import [namespace parent]::extract
}
proc docstrip::util::fileoptions {args} {
   variable filename
   variable thefile [eval [list thefile $filename] $args]
   variable fileoptions $args
}
proc docstrip::util::Report {item} {
   variable Report_store
   if {$Report_store} then {
      variable Report
      lappend Report $item
   }
   variable Report_cmd
   eval [linsert $Report_cmd end $item]
}
proc docstrip::util::index_from_catalogue {dir pattern args} {
   array set O {
      -options ""
      -sourceconf ""
      -report 0
      -reportcmd {puts stdout}
      -RecursionDepth 0
   }
   array set O $args
   if {$O(-RecursionDepth)==0} then {
      variable Report {}  Report_store $O(-report) \
        Report_cmd $O(-reportcmd)
   }
   set targetFn [file join $dir pkgIndex.tcl]
   Report "Entries will go to: $targetFn"
   if {![file exists $targetFn]} then {
      Report "Generating empty index file."
      set F [open $targetFn w]
      puts $F {# Tcl package index file, version 1.1}
      puts $F {# This file is generated by the "pkg_mkIndex" command}
      puts $F {# and sourced either when an application starts up or}
      puts $F {# by a "package unknown" script.  It invokes the}
      puts $F {# "package ifneeded" command to set up package-related}
      puts $F {# information so that packages will be loaded automatically}
      puts $F {# in response to "package require" commands.  When this}
      puts $F {# script is sourced, the variable $dir must contain the}
      puts $F {# full path name of this file's directory.}
      close $F
   }
   set c [interp create -safe]
   $c eval {
      proc unknown args {}
   }
   $c alias pkgProvide [namespace which PkgProvide]
   $c alias pkgIndex [namespace which PkgIndex]
   $c alias fileoptions [namespace which fileoptions]
   variable PkgIndex ""
   foreach fn [glob -nocomplain -directory $dir -tails $pattern] {
      Report "Processing file: $fn"
      variable filename [file join $dir $fn]
      variable fileoptions $O(-sourceconf)
      variable thefile [eval [list thefile $filename] $fileoptions]
      set catalogue [extract $thefile\
        [linsert $O(-options) 0 docstrip.tcl::catalogue]\
        -metaprefix {#} -onerror puts]
      $c eval $catalogue
   }
   interp delete $c
   if {$PkgIndex ne ""} then {
      set F [open $targetFn {WRONLY APPEND}]
      set cmd [list docstrip::util::index_from_catalogue $dir $pattern]
      if {$O(-options) ne ""} then {
         lappend cmd -options $O(-options)
      }
      if {$O(-sourceconf) ne ""} then {
         lappend cmd -sourceconf $O(-sourceconf)
      }
      puts $F "\n## Appendix generated by:\n##  $cmd$PkgIndex"
      close $F
   }
   if {[info exists O(-recursein)]} then {
      incr O(-RecursionDepth)
      foreach fn [
         glob -nocomplain -tails -types d -directory $dir\
           $O(-recursein)
      ] {
         eval [list index_from_catalogue [file join $dir $fn] $pattern]\
           [array get O]
      }
   }
   if {$O(-RecursionDepth)==0 && $O(-report)} then {
      return [join $Report \n]
   }
}
proc docstrip::util::PkgProvide {pkg ver terminals} {
   if {[catch {package vcompare 0 $ver}]} then {
      Report "Malformed version number $ver given for package $pkg."
      return
   }
   variable PkgIndex
   variable filename
   variable fileoptions
   append PkgIndex \n [list package ifneeded $pkg $ver] { "}
   append PkgIndex [string map {\\ {\\} \$ {\$} \[ {\[} \" {\"}}\
     [list package provide $pkg $ver]] {; }
   append PkgIndex {package require docstrip} {; }
   append PkgIndex {[list docstrip::sourcefrom }\
     {[file join $dir } [list [file tail $filename]] {] }\
     [linsert $fileoptions 0 $terminals] {]"}
}
proc docstrip::util::PkgIndex {args} {
   variable thefile
   if {[catch {
      packages_provided [extract $thefile $args -metaprefix {#}]
   } res]} then {
      if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
         Report "Stripping error \"$res\"\nwhile indexing module\
           <[join $args ,]>."
      } else {
         Report "Code evaluation error:\n  $res\nwhile indexing\
           module <[join $args ,]>."
      }
   } else {
      variable filename
      variable PkgIndex
      variable fileoptions
      foreach {pkg ver} $res {
         append PkgIndex \n [list package ifneeded $pkg $ver] { "}
         append PkgIndex {package require docstrip} {; }
         append PkgIndex {[list docstrip::sourcefrom }\
           {[file join $dir } [list [file tail $filename]] {] }\
           [linsert $fileoptions 0 $args] {]"}
      }
   }
}
proc docstrip::util::modules_from_catalogue {target source args} {
   array set Opt {
      -formatpostamble {classical_postamble {##}}
      -formatpreamble  {classical_preamble {##}}
      -options         {}
      -postamble       {}
      -preamble        { }
      -sourceconf      {}
      -report          1
      -reportcmd       list
   }
   array set Opt $args
   variable filename $source
   variable fileoptions $Opt(-sourceconf)
   variable thefile [eval [list thefile $source] $fileoptions]
   variable Report {}  Report_store $O(-report) \
     Report_cmd $O(-reportcmd)
   set catalogue [extract $thefile\
     [linsert $Opt(-options) 0 docstrip.tcl::catalogue]\
     -metaprefix {#} -onerror puts]
   set c [interp create -safe]
   $c eval {
      proc unknown args {}
   }
   $c alias pkgProvide\
     [namespace which GenerateNamedPkg] $target\
     [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
     [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
   $c alias pkgIndex\
     [namespace which GeneratePkg] $target\
     [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
     [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
   $c alias fileoptions [namespace which fileoptions]
   $c eval $catalogue
   interp delete $c
   if {$O(-report)} then {return [join $Report \n]}
}
proc docstrip::util::GenerateNamedPkg\
  {target preamblecmd postamblecmd name version terminals} {
   variable thefile
   if {[catch {
      extract $thefile $terminals -metaprefix {#}
   } text]} then {
      Report "Stripping error \"$text\"\nwhile indexing module\
        <[join $terminals ,]>."
   } else {
      variable filename
      set module [format {%s-%s.tm}\
        [string trim [string map {:: /} $name] /] $version]
      set modL [file split $module]
      file mkdir [file join $target [file dirname $module]]
      set F [open [file join $target $module] w]
      fconfigure $F -encoding utf-8
      puts $F [eval $preamblecmd [list $module $filename $terminals]]
      puts -nonewline $F $text
      puts $F [eval $postamblecmd [list $module $filename $terminals]]
      close $F
      Report "Wrote $module"
   }
}
proc docstrip::util::GeneratePkg {target preamblecmd postamblecmd args} {
   variable thefile
   if {[catch {
      set text [extract $thefile $args -metaprefix {#}]
      packages_provided $text
   } res]} then {
      if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
         Report "Stripping error \"$res\"\nwhile indexing module\
           <[join $args ,]>."
      } else {
         Report "Code evaluation error:\n  $res\nwhile indexing\
           module <[join $args ,]>."
      }
   } elseif {![llength $res]} then {
      Report "Found no package in module <[join $args ,]>."
   } else {
      variable filename
      set module [format {%s-%s.tm}\
        [string trim [string map {:: /} [lindex $res 0]] /]\
        [lindex $res 1]]
      set modL [file split $module]
      file mkdir [file join $target [file dirname $module]]
      set F [open [file join $target $module] w]
      fconfigure $F -encoding utf-8
      puts $F [eval $preamblecmd [list $module $filename $args]]
      puts -nonewline $F $text
      puts $F [eval $postamblecmd [list $module $filename $args]]
      close $F
      Report "Wrote $module"
      foreach {pkg ver} [lreplace $res 0 1] {
         set mod2 [format {%s-%s.tm}\
           [string trim [string map {:: /} $pkg] /] $ver]
         set mod2L [file split $mod2]
         file mkdir [file join $target [file dirname $mod2]]
         set common 0
         foreach d1 $modL d2 $mod2L {
            if {$d1 eq $d2} then {incr common} else {break}
         }
         set tail [lrange $modL $common end]
         set script {[::info script]}
         foreach d2 $mod2L {
            if {[incr common -1] < 0} then {
               set script "\[::file dirname $script\]"
            }
         }
         set F [open [file join $target $mod2] w]
         fconfigure $F -encoding utf-8
         puts $F "::source -encoding utf-8 \[::file join $script $tail\]"
         close $F
         Report "Wrote redirect $mod2"
      }
   }
}
proc docstrip::util::classical_preamble {metaprefix message target args} {
   set res {""}
   lappend res " This is `$target',"
   lappend res { generated by the docstrip::util package.}
   lappend res {} { The original source files were:} {}
   foreach {source terminals} $args {
      set line " [file tail $source]"
      if {[llength $terminals]} then {
         append line { (with options: `} [join $terminals ,] {')}
      }
      lappend res $line
   }
   foreach line [split $message \n] {lappend res " $line"}
   return $metaprefix[join $res "\n$metaprefix"]
}
proc docstrip::util::classical_postamble {metaprefix message target args} {
   set res {}
   foreach line [split $message \n] {lappend res " $line"}
   lappend res {} " End of file `$target'."
   return $metaprefix[join $res "\n$metaprefix"]
}
proc docstrip::util::packages_provided {text {setup ""}} {
   set c [interp create -safe]
   $c eval {
      proc tclPkgUnknown args {}
      package unknown tclPkgUnknown
      proc unknown {args} {}
      proc auto_import {args} {}
   }
   $c hide package
   $c alias package [namespace which packages_provided,package] $c
   eval $setup
   set package_list {}
   catch {$c eval $text}
   interp delete $c
   return $package_list
}
proc docstrip::util::packages_provided,package {interp subcmd args} {
   switch -- $subcmd {
      r - re - req - requ - requi - requir - require {
         return
      }
      pro - prov - provi - provid - provide {
         if {[llength $args] == 2} then {
            uplevel 1 [list lappend package_list] $args
         }
      }
   }
   eval [list $interp invokehidden package $subcmd] $args
}
proc docstrip::util::ddt2man {text} {
   set wascode 0
   set verbatim 0
   set res ""
   foreach line [split $text \n] {
      if {$verbatim} then {
         if {$line eq $endverbline} then {
            set verbatim 0
         } else {
            append res [string map {[ [lb] ] [rb]} $line] \n
         }
      } else {
         switch -glob -- $line %%* {
            if {$wacode} then {
               append res {[example_end]} \n
               set wascode 0
            }
            append res [string range $line 2 end] \n
         } %<<* {
            if {!$wascode} then {
               append res {[example_begin]} \n
               set wascode 1
            }
            set endverbline "%[string range $line 3 end]"
            set verbatim 1
         } %<* {
            if {!$wascode} then {
               append res {[example_begin]} \n
               set wascode 1
            }
            set guard ""
            regexp -- {(^%<[^>]*>)(.*)$} $line "" guard line
            append res \[ [list emph $guard] \]\
              [string map {[ [lb] ] [rb]} $line] \n
         } %* {
            if {$wascode} then {
               append res {[example_end]} \n
               set wascode 0
            }
            append res [string range $line 1 end] \n
         } {\\endinput} {
           break
         } "" {
            append res \n
         } default {
            if {!$wascode} then {
               append res {[example_begin]} \n
               set wascode 1
            }
            append res [string map {[ [lb] ] [rb]} $line] \n
         }
      }
   }
   if {$wascode} then {append res {[example_end]} \n}
   return $res
}
proc docstrip::util::guards {subcmd text} {
   set verbatim 0
   set lineno 1
   set badL {}
   foreach line [split $text \n] {
      if {$verbatim} then {
         if {$line eq $endverbline} then {set verbatim 0}
      } else {
         switch -glob -- $line %<<* {
            set endverbline "%[string range $line 3 end]"
            set verbatim 1
         } %<* {
            if {![
               regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\
                 modifier expression line
            ]} then {
               lappend badL $lineno $line
            } else {
               if {$modifier eq ""} then {set modifier " "}
               append E($expression) $modifier
            }
         }
      }
      incr lineno
   }
   if {$subcmd eq "rotten"} then {return $badL}
   switch -- $subcmd "exprmods" {
      return [array get E]
   } "expressions" {
      return [array names E]
   } "exprerr" {
      set res {}
      foreach expr [array names E] {
         regsub -all {[^()!,|&]+} $expr 0 e
         regsub -all {,} $e {|} e
         if {[catch {expr $e}]} then {lappend res $expr}
      }
      return $res
   }
   foreach name [array names E] {
      set E($name) [string length $E($name)]
   }
   if {$subcmd eq "exprcounts"} then {return [array get E]}
   foreach expr [array names E] {
      foreach term [split $expr "()!,|&"] {
         if {$term eq ""} then {continue}
         if {![info exists T($term)]} then {set T($term) 0}
         incr T($term) $E($expr)
      }
   }
   switch -- $subcmd "counts" {
      return [array get T]
   } "names" {
      return [array names T]
   } default {
      error "Unknown subcommand '$subcmd', must be one of:\
        counts, exprcounts, expressions, exprmods, names, rotten"
   }
}
proc docstrip::util::patch {sourcevar termL fromtext diff args} {
   upvar 1 $sourcevar SL
   array set O {-trimlines 1 -matching exact}
   array set O $args
   set cmd [list extract [join $SL \n]  $termL -annotate 2]
   foreach opt {-metaprefix -trimlines} {
      if {[info exists O($opt)]} then {lappend cmd $opt $O($opt)}
   }
   set EL [split [eval $cmd] \n]
   lset EL end \n
   set ptr 0
   set lineno 1
   set FL [list {}]
   foreach line [split $fromtext \n] {
      lappend FL $line
      if {$O(-trimlines)} then {set line [string trimright $line " "]}
      if {$line eq [lindex $EL $ptr]} then {
         set lift($lineno) [lindex $EL [incr ptr]]
         lset lift($lineno) 0 [expr { [lindex $EL [incr ptr]] - 1 }]
         incr ptr
      }
      incr lineno
   }
   if {![array size lift]} then {
      return -code error "The extract did not match any part of the\
        fromtext. Check the list of terminals and the options"
   }
   set RL [list]
   set log [list]
   foreach hunk [lsort -decreasing -integer -index 0 $diff] {
      set replL [list]
      set l1 [lindex $hunk 0]
      set repl {0 -1}
      set matches 1
      foreach {type line} [lindex $hunk 4] {
         switch -glob -- $type {[0-]} {
            switch -- $O(-matching) "exact" {
               if {[lindex $FL $l1] ne $line} then {set matches 0}
            } "nonspace" {
               if {[regsub -all -- {\s} $line {}] ne\
                 [regsub -all -- {\s} [lindex $FL $l1] {}]} then {
                  set matches 0
               }
            } "anyspace" {
               if {[regsub -all -- {\s+} $line { }] ne\
                 [regsub -all -- {\s+} [lindex $FL $l1] { }]} then {
                  set matches 0
               }
            }
         }
         switch -- $type synch {
            if {[llength $repl]>2 ||\
              [lindex $repl 1]-[lindex $repl 0]>=0} then {
               lappend replL $repl
            }
            set repl [list $l1 [expr {$l1-1}]]
         } + {
            lappend repl $line
         } - {
            lset repl 1 $l1
            incr l1
         } 0 {
            if {[llength $repl]>2 ||\
              [lindex $repl 1]-[lindex $repl 0]>=0} then {
               lappend replL $repl
               set repl {0 -1}
            }
            lset repl 1 $l1
            incr l1
            lset repl 0 $l1
         }
      }
      if {[llength $repl]>2 || [lindex $repl 1]-[lindex $repl 0]>=0}\
      then {lappend replL $repl}
      if {$matches} then {
         lappend hunk [lsort -decreasing -integer -index 0 $replL]
         lappend RL $hunk
      } else {
         lappend hunk "(-- did not match fromtext --)"
         lappend log $hunk
      }
   }
   foreach hunk $RL {
      set applied 0
      set misapplied 0
      foreach repl [lindex $hunk 5] {
         unset -nocomplain from to
         for {set n [lindex $repl 1]} {$n>=[lindex $repl 0]}\
           {incr n -1} {
            if {![info exists lift($n)]} then {
               incr misapplied
               continue
            } elseif {![info exists from]} then {
               set to [lindex $lift($n) 0]
               set from $to
            } elseif {[lindex $lift($n) 0] == $from-1} then {
               set from [lindex $lift($n) 0]
            } else {
               set SL [lreplace $SL $from $to]
               set to [lindex $lift($n) 0]
               set from $to
            }
            incr applied
            set n0 $n
         }
         if {[info exists from]} then {
            set sprefix [lindex $lift($n0) 1]
            set eprefix [lindex $lift($n0) 2]
         } elseif {[info exists lift([lindex $repl 0])]} then {
            foreach {from sprefix eprefix} $lift([lindex $repl 0])\
              break
            set to [expr {$from-1}]
         } else {
            incr misapplied [llength [lrange $repl 2 end]]
            continue
         }
         set eplen [string length $eprefix]
         set epend [expr {$eplen-1}]
         set cmd [list lreplace $SL $from $to]
         foreach line [lrange $repl 2 end] {
            if {$eprefix eq [string range $line 0 $epend]} then {
               lappend cmd "$sprefix[string range $line $eplen end]"
            } else {
               lappend cmd $line
            }
            incr applied
         }
         set SL [eval $cmd]
      }
      if {$misapplied>0} then {
         if {$applied>0} then {
            lset hunk 5 "(-- was partially applied --)"
         } else {
            lset hunk 5 "(not applied)"
         }
         lappend log $hunk
      }
   }
   set res ""
   foreach hunk [lsort -index 0 -integer $log] {
      foreach {start1 end1 start2 end2 lines msg} $hunk break
      append res [format "@@ -%d,%d +%d,%d @@ %s\n"\
        $start1 [expr {$end1-$start1+1}]\
        $start2 [expr {$end2-$start2+1}] $msg]
      foreach {type line} $lines {
         switch -- $type 0 {
            append res " " $line \n
         } - - + {
            append res $type $line \n
         }
      }
   }
   return $res
}
proc docstrip::util::thefile {fname args} {
   set F [open $fname r]
   if {[llength $args]} then {
      if {[set code [
         catch {eval [linsert $args 0 fconfigure $F]} res
      ]]} then {
         close $F
         return -code $code -errorinfo $::errorInfo -errorcode\
           $::errorCode
      }
   }
   catch {read -nonewline $F} res
   close $F
   return $res
}
proc docstrip::util::import_unidiff {text {warnvar ""}} {
   if {$warnvar ne ""} then {upvar 1 $warnvar warning}
   set inheader 1
   set res [list]
   set lines [list]
   set end2 "not an integer"
   foreach line [split $text \n] {
      if {$inheader && [regexp {^(---|\+\+\+)} $line]}\
      then {continue}
      switch -glob -- $line { *} {
         lappend lines 0 [string range $line 1 end]
      } {+*} {
         lappend lines + [string range $line 1 end]
      } {-*} {
         lappend lines - [string range $line 1 end]
      } @@* {
         if {[string is integer $end2]} then {
            lappend res [list $start1 $end1 $start2 $end2 $lines]
         }
         set len2 [set len1 ,1]
         if {[
            regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@}\
              $line -> start1 len1 start2 len2
         ] && [scan "$start1 $len1,1" {%d ,%d} start1 len1]==2 &&\
              [scan "$start2 $len2,1" {%d ,%d} start2 len2]==2
         } then {
            set end1 [expr {$start1+$len1-1}]
            set end2 [expr {$start2+$len2-1}]
            set inheader 0
         } else {
            set end2 "not an integer"
            append warning "Could not parse hunk header:  " $line \n
         }
         set lines [list]
      } "" {
      } default {
         append warning "Could not parse line:  " $line \n
      }
   }
   if {[string is integer $end2]} then {
      lappend res [list $start1 $end1 $start2 $end2 $lines]
   }
   return $res
}
## 
## 
## End of file `docstrip_util.tcl'.