# -*- Tcl -*-                 monotone.tcl (c) Clemens Hintze 01.02.2004
#
# This module is used to parse a monotone repository to collect important
# information of all revisions contained in that repository. Furthermore
# it can be used to create package dumps of old I/O package format to
# transport the contents of a repository to another one.
#
# You may use this module under the same license as Tcl's one. You may not
# claim you wrote it or remove this comment header. As this is made
# available free of charge I do not warrant anything. Using this module
# even may blow up your computer, your cat and your whole home. You was
# warned ;-)

namespace eval monotone {

  namespace export                                              \
      Init                                                      \
      GetCurrentId GetIdOfPartId GetIdOfSelector GetIdOfTag     \
      GetAncestors GetShortestAncestorPath                	\
      GetContentsOfRevision GetContentsOfManifest               \
      GetContentsOfFile OnEachManifestEntry                  	\
      DumpManifest DumpRevision

  variable cmd "monotone"

  proc Init {args} {
    variable cmd
    set array [lindex $args end]
    upvar $array repos
    array unset repos
    if {[getOpts opts $args] < 1} {
      error "wrong # args: Init ?-db dbfile? ?-rcfile rcfile? arrayname"
    }
    foreach opt [array names opts] {
      lappend repos(opts) "--$opt=$opts($opt)"
    }
    if {![info exists opts(db)]} {
      if {[catch {
	set fd [open "MT/options"]; set options [read $fd]; close $fd
	if {![regexp -line {database "?([^\"]*)"?} $options -> db]} {
	  error !
	}
	lappend repos(opts) "--db=$db"
      }]} {
	error "cannot determine, which repository to use"
      }
    }
    analyzeGraph repos
    set result [readFrom -trim $cmd --quiet list tags $repos(opts)]
    foreach tagline [split $result "\n"] {
      foreach {tag id _} [split $tagline] break
      lappend repos(tags) $tag
      lappend repos($id,tag) $tag
      set repos(tag,$tag) $id
    }
  }

  proc GetHeadsOfBranch {array branch} {
    upvar $array repos
    variable cmd
    set result [readFrom -trim $cmd --quiet --branch=$branch heads $repos(opts)]
    set heads {}
    foreach line [split [K $result [set result {}]] "\n"] {
      lappend heads [lindex [split $line] 0]
    }
    return $heads
  }

  proc GetCurrentId {array} {
    upvar $array repos
    variable cmd
    set result [readFrom -trim $cmd --quiet status $repos(opts)]
    set splitted [split [K $result [set result {}]] "\n"]
    foreach line [K $splitted [set splitted {}]] {
      if {[regexp {^old_revision \[([0-9a-h]+)\]\s*$} $line -> id]} {
	return $id
      }
    }
    error "not in a monotone repository"
  }   

  proc GetIdOfPartId {args} {
    variable cmd
    if {[llength $args] == 3} {
      set opt [lvarshift args]
      switch -exact -- $opt {
	-file     { set what file }
	-manifest { set what manifest }
	-revision { set what revision }
	default   { 
	  error "bad argument \"$opt\": must be one of -file, -manifest or -revision"
	}
      }
    } elseif {[llength $args] == 2} {
      set what manifest
    } else {
      error "wrong \# args: \"GetIdOfPartId ?-file|-manifest|-revision? array partid\""
    }
    upvar [lvarshift args] repos
    set partid [lvarshift args]
    set res [readFrom -trim $cmd --quiet complete $what $partid $repos(opts)]
    return $res
  }

  proc GetIdOfSelector {array id} {
    upvar $array repos
    variable cmd
    set res [readFrom -trim $cmd diff [list $id] [list $id] $repos(opts)]
    if {![regexp {expanded to '([0-9a-h]+)'} $res -> id]} {
      regexp {ambiguous expansions:\s*(.+)$} $res -> ids
      set result {}
      foreach id [split $ids "\n"] {
	lappend result [lindex [split $id] 0]
      }
      set id $result
    }
    return $id
  }

  proc GetIdOfTag {array tag} {
    upvar $array repos
    set result {}
    set pos 0
    while {[set pos [lsearch -glob -start $pos $repos(tags) $tag]] != -1} {
      lappend result $repos(tag,[lindex $repos(tags) $pos]) 
      incr pos
    }
    return $result
  }

  proc GetAncestors {array id {depth 1}} {
    upvar $array repos
    lappend todo $id
    set seen($id) 1
    set nextlevel empty
    set result {}
    while {$depth != 0 && [llength $nextlevel] != 0} {
      set nextlevel {}
      while {[llength $todo] > 0} {
	set mid [lvarpop todo]
	if {![info exists repos($mid,ancestors)]} continue
	foreach anc $repos($mid,ancestors) {
	  if {![info exists seen($anc)]} {
	    lappend nextlevel $anc
	    set seen($anc) 1
	  }
	}
      }
      set result [concat [K $result [set result {}]] [set todo $nextlevel]]
      incr depth -1
    }  
    return $result
  }

  proc GetShortestAncestorPath {array id ancestor} {
    upvar $array repos 
    lappend todo $id
    while {[llength $todo]} {
      set mid [lvarshift todo]
      set result $mid
      if {$mid == $ancestor} break
      catch {
	foreach anc $repos($mid,ancestors) {
	  lappend backlist($anc) $mid
	  lappend todo $anc
	}
      }
    }
    if {[string compare $mid $ancestor] != 0} return
    set id $result
    while {[info exists backlist($id)]} {      
      lappend result [set id [lindex $backlist($id) 0]]
    }
    return $result
  }

  proc GetAncestorPathOnBranch {array branch {heads {}}} {
    upvar $array repos 
    variable cmd
    if {$heads == {}} {
      set heads [GetHeadsOfBranch repos $branch]
    }
    set path {}
    set todo $heads
    array set visited {}
    while {[llength $todo] > 0} {
      set id [lvarshift todo]
      if {[info exists visited($id)]} continue
      set visited($id) 1
      if {[lsearch $repos($id,branches) $branch] != -1} {
	lappend path $id
      }
      if {[info exists repos($id,ancestors)]} {
	eval [linsert $repos($id,ancestors) 0 lappend todo]
      }
    }
    return $path
  }

  proc GetAnchorRevisions {array} {
    upvar $array repos 
    variable cmd
    set anchors {}
    foreach rev $repos(revisions) {
      if {![info exists repos($rev,ancestors)]} {
	lappend anchors $rev
      }
    }
    return $anchors
  }
  
  proc GetHeadRevisions {array} {
    upvar $array repos 
    variable cmd
    set childs {}
    foreach rev $repos(revisions) {
      if {![info exists repos($rev,childs)]} {
	lappend childs $rev
      }
    }
    return $childs
  }
  
  proc GetContentsOfRevision {array id} {
    upvar $array repos 
    variable cmd
    array set data {}
    set result [readFrom $cmd --quiet cat revision $id $repos(opts)]
    foreach line [split $result "\n"] {
      if {[regexp {^new_manifest \[([0-9a-h]+)\]} $line -> mid]} {
	set data(manifest) $mid
      } elseif {[regexp {^old_manifest \[([0-9a-h]+)\]} $line -> mid]} {
	set data(parent,manifest) $mid
      } elseif {[regexp {^old_revision \[([0-9a-h]+)\]} $line -> rid]} {
	set data(parent,revision) $rid
      } elseif {[array size repos] >= 3} {
        lappend data(contents) $line
      }
    }
    return [array get data]
  }

  proc GetCertsOfRevision {array id} {
    upvar $array repos
    variable cmd
    array set result {}
    set rcerts [readFrom -trim $cmd --quiet list certs $id $repos(opts)]
    onEachCert cert $rcerts {
      lappend result($cert(name)) [array get cert]
    }
    return [array get result]
  }

  proc GetContentsOfManifest {args} {
    set argc [llength $args]
    if {$argc < 2 || $argc > 3} {
      error "wrong # args: GetContentsOfManifest ?-file? array id"
    } elseif {[string compare [lindex $args 0] "-file"] == 0} {
      lvarshift args
      set filekey 1
    }
    upvar [lvarshift args] repos
    set id [lvarshift args]
    set result {}
    OnEachManifestEntry repos entry $id {
      if {[info exists filekey]} {
	lappend result $entry(file) $entry(id)
      } else {
	lappend result $entry(id) $entry(file)
      }
    }
    return $result
  }

  proc GetContentsOfFile {array mid fid} {
    upvar $array repos
    variable cmd
    array set contents [GetContentsOfManifest repos $mid]
    if {[catch {set contents($fid)} file]} {
      set listing [array get contents]
      set pos [lsearch -exact $listing $fid]
      if {$pos == -1} {
	error [format "bad argument: no such file \"%s\"" $fid]
      }
      set fid [lindex $listing [incr pos -1]]
    }
    readFrom $cmd --quiet cat file $fid $repos(opts)
  }

  proc WalkOnRevisionGraph {direct array varname script} {
    upvar $array repos
    upvar $varname id
    variable cmd
    switch -- $direct {
      -up   {
	set direct ancestors
	set baserevs [GetHeadRevisions repos]
      }
      -down {
	set direct childs
	set baserevs [GetAnchorRevisions repos]
      }
      default { 
	error "bad direction: should be -up or -down" 
      }
    }
    array set visited {}
    foreach base $baserevs {
      set todo $base
      while {[llength $todo] > 0} {
	set id [lvarshift todo]
	if {[info exists visited($id)]} continue
	set visited($id) 1
	if {[info exists repos($id,$direct)]} {
	  eval [linsert $repos($id,$direct) 0 lappend todo]
	}
	uplevel $script
      }
    }
  }

  proc DumpRevision {array id {ancestor ""}} {
    upvar $array repos
    variable cmd
    if {$ancestor != {}} {
      array set contents [GetContentsOfRevision repos $ancestor]
      set ancestor $contents(manifest)
    }
    set dump [eval exec $cmd rdata $id $repos(opts)]\n
    append dump [eval exec $cmd certs $id $repos(opts)]\n
    array set contents [GetContentsOfRevision repos $id]
    append dump [DumpManifest repos $contents(manifest) $ancestor]\n
    return $dump
  }

  proc DumpManifest {array id {ancestor ""}} {
    upvar $array repos
    variable cmd
    set what data
    if {[string length $ancestor] != 0} {
      set what "delta $ancestor"
      array set acontents [GetContentsOfManifest -file repos $ancestor]
    }
    set dump {}
    if {[catch {append dump [eval exec $cmd m$what $id $repos(opts)]\n} msg]} {
      append dump [eval exec $cmd mdata $id $repos(opts)]\n
    }
    OnEachManifestEntry repos entry $id {
      set file $entry(file)
      if {[info exists acontents($file)] && $entry(id) == $acontents($file)} {
      	continue
      }
      if {[catch {
	append dump [eval exec $cmd fdelta $acontents($file) $entry(id) $repos(opts)]\n
      }]} {
	append dump [eval exec $cmd fdata $entry(id) $repos(opts)]\n
      }
    }
    return $dump
  }

  proc OnEachManifestEntry {array varname id script} {
    upvar $array repos $varname var
    variable cmd
    set result [readFrom $cmd --quiet cat manifest $id $repos(opts)]
    set splitted [split [K $result [set result {}]] "\n"]
    foreach entry [K $splitted [set splitted {}]] {
      if {[regexp {^([0-9a-h]+)\s+(.*)} $entry -> var(id) var(file)]} {
	uplevel $script
      }
    }    
  }

  proc getOpts {optarray arglist} {
    upvar $optarray opts
    while {[llength $arglist] > 1} {
      set opt [lvarshift arglist]
      switch -exact -- $opt {
	-db     { set opts(db)     [lvarshift arglist] }
	-rcfile { set opts(rcfile) [lvarshift arglist] }
	-key    { set opts(key)    [lvarshift arglist] }
	-branch { set opts(branch) [lvarshift arglist] }
	default { return -1 }
      }
    }
    return [llength $arglist]
  }

  proc analyzeGraph {array} {
    upvar $array repos
    variable cmd
    array set branches {}
    set entries [readFrom -trim $cmd --quiet agraph $repos(opts)]
    set edgere {^edge: \{ sourcename : "([^\"]+)"\s+?targetname : "([^\"]+)"}
    set nodere {^node: \{ title : "([^\"]+)"\s+?label : "([^\"]+)"}
    foreach entry [split $entries "\}"] {
      set trimmed [string trim $entry]
      if {[regexp $edgere $trimmed -> source target]} {
	lappend repos($target,ancestors) $source
	lappend repos($source,childs) $target
      } elseif {[regexp $nodere $trimmed -> revision label]} {
	set pos [string first $label {\n}]
	regsub -all {\\n} $label "\n" label
	regsub -all {\\f.} $label {} label
	foreach branch [lrange [split $label "\n"] 1 end] {
	  set branches($branch) 1
	  lappend repos($revision,branches) $branch
	}
	lappend repos(revisions) $revision
      }	
    }
    eval [linsert [array names branches] 0 lappend repos(branches)]
  }
	  
  proc analyzeRevision {array id} {
    upvar $array repos
    variable cmd
    set rcerts [readFrom -trim $cmd --quiet list certs $id $repos(opts)]
    onEachCert cert $rcerts {
      lappend repos($id,cert,$cert(name)) [array get cert]
    }
    set contents [readFrom -trim $cmd --quiet cat revision $id $repos(opts)]
    set repos($id,revision) $contents
  }

  proc onEachCert {array certs script} {
    upvar $array cert
    array unset cert
    foreach line [split $certs "\n"] {
      if {[regexp -- {^-+$} $line]} {
	if {[array size cert] != 0} {
	  uplevel $script
	  array unset cert
	}
      } elseif {[regexp {^\s+: (.*)$} $line -> value]} {
	append cert(value) "\n" $value
      } elseif {[regexp {^\s*(Key|Sig|Name|Value)\s*: (.*)$} $line -> i v]} {
	set cert([string tolower $i]) $v
      }
    }
    if {[array size cert] != 0} {
      uplevel $script
    }
  }

  proc readFrom {args} {
    set trim 0
    if {[lindex $args 0] == "-trim"} {
      set trim 1
      set args [lrange $args 1 end]
    }
    set cmd [lvarshift args]
    set arglist [eval concat $args]
    if {[catch {open "|[auto_execok $cmd] $arglist"} md]} {
      error "Could not execute \"$cmd $args\"! Reason: $md"
    }
    set result [read $md]
    if {[catch {close $md} msg]} {
      set result $msg
    }
    if {$trim} { set result [string trimright $result] }
    return $result
  }

  proc K {x args} { set x }

  proc lvarshift {varname} {
    upvar $varname list
    set top [lindex $list 0]
    set list [lrange [K $list [set list {}]] 1 end]
    return $top
  }

  proc lvarpop {varname} {
    upvar $varname list
    set bottom [lindex $list end]
    set list [lrange [K $list [set list {}]] 0 end-1]
    return $bottom
  }
  
  proc lreverse L {
    set res {}
    set i [llength $L]
    while {$i} {lappend res [lindex $L [incr i -1]]}
    set res
  }
}

package provide monotone

#monotone::Init repos
#parray repos

#puts [monotone::GetIdOfSelector repos "LATEST_ALCATEL"]
#puts [monotone::GetIdOfTag repos ALCATEL]

#set pos [lsearch $repos(manifests) 0d0ff*]
#set pos [lsearch $repos(manifests) c5372*]
#set id [lindex $repos(manifests) $pos]

#puts "Ancestors:\t[join [monotone::GetAncestors repos $id] "\n\t\t"]"
#puts "Ancestors:\t[join [monotone::GetAncestors repos $id 2] "\n\t\t"]"
#puts "Ancestors:\t[join [monotone::GetAncestors repos $id -1] "\n\t\t"]"

#puts [monotone::GetContentsOfManifest repos $id]
#puts [monotone::GetContentsOfFile repos $id "inc/pcm_manager.h"]
#puts [monotone::GetContentsOfFile repos $id 7e6e3a817d9d5d8d7ba4d44ce736c95b3f83db0e]

#monotone::Complete repos d
#monotone::Complete -manifest repos d
#monotone::Complete -manifest repos cfd
#monotone::Complete -file repos cfd

#puts [monotone::GetShortestAncestorPath repos \
#        4c1756a5c0556422698b438093105983d4641dc2 \
#        6504fa512d6bbce4c7fcbdb44c3bd71a2823283d]
#puts [monotone::GetShortestAncestorPath repos \
#	ebb1d12981b49e92b6be8c2ff286f9dce9320a29 \
#	6fed1c0ad189fc66c982093e8bf6d07dd9c5ce3b]
#puts [monotone::GetShortestAncestorPath repos \
#	ebb1d12981b49e92b6be8c2ff286f9dce9320a29 \
#	fc34e44d8d2ac3e3d8e6c82578ae6361228b02c5]

#monotone::DumpManifest repos $id 2