joincanvas.tcl

TKCVS Source Code For CVS。

#
# Tcl Library for TkCVS
#

namespace eval joincanvas {
  variable instance 0

  proc new {localfile filelog {current_tagname {}}} {
    variable instance
    set my_idx $instance
    incr instance

    if {[catch "image type Modules"]} {
      workdir_images
    }
    if {[catch "image type Workdir"]} {
      modbrowse_images
    }

    #
    # Creates a new log canvas.  filelog must be the output of a cvs
    # log or rlog command.
    #
    namespace eval $my_idx {
      set my_idx [uplevel {concat $my_idx}]
      set filelog [uplevel {concat $filelog}]
      variable localfile [uplevel {concat $localfile}]
      variable current_tagname [uplevel {concat $current_tagname}]

      global cvscfg
      global cvsglb
      global cvs
      global tcl_platform

      # Height and width to draw boxes
      variable cvscanv
      set cvscanv(boxx) 60
      set cvscanv(boxy) 20
      set cvscanv(midx) [expr {$cvscanv(boxx) / 2}]
      set cvscanv(midy) [expr {$cvscanv(boxy) / 2}]
      set cvscanv(boxmin) 64
      # Gaps between boxes
      set cvscanv(space) [expr {$cvscanv(boxy) + 16}]
      # Indent at top left of canvas
      set cvscanv(indx) 5
      set cvscanv(indy) 5
      # Static type variables used while drawing on the canvas.
      set cvscanv(xhigh) 0
      set cvscanv(yhigh) 0
      set cvscanv(xlow)  0
      set cvscanv(ylow)  0

      variable revlist
      variable revbranches
      variable tags
      variable headrev
      variable joincanvas

      set joincanvas ".joincanvas$my_idx"

      proc parse_cvslog_tags {filelog} {
        variable joincanvas
        variable tags
        variable headrev

        gen_log:log T "ENTER ($joincanvas ...)"
        set loglist [split $filelog "\n"]
        set logstate "rcsfile"
        foreach logline $loglist {
          #puts "$logline"
          switch -exact -- $logstate {
            "rcsfile" {
              # Look for the first text line which should give the file name.
              set fileline [split $logline]
              if {[lindex $fileline 0] == "RCS"} {
                set logstate "head"
                continue
              }
            }
            "head" {
              set fileline [split $logline]
              if {[lindex $fileline 0] == "head:"} {
                set headrev [lindex $fileline 1]
                set logstate "tags"
                set taglist ""
                continue
              }
            }
            "tags" {
              # Any line with a tab leader is a tag
              if { [string index $logline 0] == "\t" } {
                set taglist "$taglist$logline\n"
                set tagitems [split $logline ":"]
                set tagrevision [string trim [lindex $tagitems 1]]
                set tagname [string trim [lindex $tagitems 0]]
                # Add all the tags to a picklist for our "since" tag
                ::picklist::used alltags $tagname

                set parts [split $tagrevision {.}]
                if {[expr {[llength $parts] & 1}] == 1} {
                  set parts [linsert $parts end-1 {0}]
                  set tagrevision [join $parts {.}]
                }
                # But we only want to know the branch tags
                if { [regexp {\.0\.\d+$} $tagrevision] } {
                  set tagstring [string trim [lindex $tagitems 0]]
                  lappend tags($tagrevision) $tagstring
                }
              } else {
                if {$logline == "description:"} {
                  # No more tags after this point
                  set logstate "searching"
                  continue
                }
                if {$logline == "----------------------------"} {
                  # Oops, missed something.
                  set logstate "revision"
                  continue
                }
              }
            }
            "terminated" {
              # ignore any further lines
              continue
            }
          }
        }
        ::picklist::used alltags ""
      }

      proc node {joincanvas rev x y} {
        global cvscfg
        variable cvscanv
        variable tags
        upvar treelist treelist
        upvar ylevel ylevel
        upvar ind ind
      
        gen_log:log T "ENTER ($rev $x $y)"
        $joincanvas.canvas create line \
          $x [expr {$y + $cvscanv(boxy)}] \
          $x [expr {$y + $cvscanv(space)}]

        gen_log:log T "LEAVE"
      }

      proc rectangle {joincanvas rev x y} {
        #
        # Breaks out some of the code from the joincanvas_draw_box procedure.
        # Work out the width of the text to go in the box first, then draw a
        # box wide enough.
        #
        global cvscfg
        variable cvscanv
        variable tags
        variable current_tagname
        upvar x xpos

        gen_log:log T "ENTER ($rev $x $y)"

        set parts [split $rev "."]

        set tagtext $tags($rev)
        gen_log:log D "$tagtext\t$rev"
        $joincanvas.canvas create text \
           [expr {$x + 4}] [expr {$y + 2}] \
           -text "$tagtext" \
           -anchor nw -fill blue \
           -font {Helvetica -12 bold} \
           -tags b$rev

        set tagwidth [font measure {Helvetica -12 bold} \
           -displayof $joincanvas.canvas $tagtext]
        if {$tagwidth < $cvscanv(boxmin)} { set tagwidth $cvscanv(boxmin) }

        # draw the box
        set boxid [$joincanvas.canvas create rectangle \
          $x $y \
          [expr {$x + $tagwidth + 5}] [expr {$y + $cvscanv(boxy)}] \
          -width 3 \
          -fill gray90 \
          -tags [list b$rev rect$rev] \
        ]
        # Drop the fill color below the text so the text isn't hidden
        $joincanvas.canvas lower $boxid

        # Bind button-presses to the rectangles.
        if {$tags($rev) != ""} {
        $joincanvas.canvas bind b$rev <ButtonPress-1> \
           [namespace code "select_rectangle $rev $tags($rev)"]
        }

        if {"$current_tagname" == "$tagtext"} {
          you_are_here $rev $tagwidth $x $y
        }
        gen_log:log T "LEAVE"
      }

      proc unselect_all {} {
        variable joincanvas
        set t [$joincanvas.canvas gettags current]
        if {$t != {} } {return}
        unselect_rectangle
      }

      proc unselect_rectangle {} {
        variable joincanvas
        catch {$joincanvas.canvas itemconfigure SelA -fill gray90}
        $joincanvas.up.rversFrom delete 0 end
        $joincanvas.canvas dtag SelA
      }

      proc select_rectangle {rev tags} {
        global cvscfg
        variable joincanvas

        gen_log:log T "ENTER ($rev $tags)"

        unselect_rectangle
        $joincanvas.up.rversFrom delete 0 end
        $joincanvas.up.rversFrom insert end $tags
        $joincanvas.canvas addtag SelA withtag rect$rev
        $joincanvas.canvas itemconfigure SelA -fill $cvscfg(colourA)
      }

      proc fillcanvas {filename filelog} {
        global cvscfg
        variable joincanvas
        variable cvscanv
        variable headrev
        variable tags
        variable current_tagname
       
        gen_log:log T "ENTER ($filename <filelog suppressed>)"

        catch {unset tags}
        # Collect the history from the RCS log
        $joincanvas.canvas delete all
        parse_cvslog_tags $filelog

        # Sort the branch revisions
        set tagrevlist [lsort -command sortrevs [array names tags]]
        # Get rid of duplicates
        set revlist ""
        foreach t $tagrevlist {
          if {[lsearch -exact $revlist $t] < 0} {
            lappend revlist $t
          }
        }

        # Find everybody's parents.  Add parent nodes to a new nodelist.
        # Keep track of everybody's children
        set treelist ""
        foreach rev $revlist {
          gen_log:log D "$rev"
          # Find its parent
          set alist [split $rev "."]
          set alength [llength $alist]
          set isodd [expr {$alength % 2}]
          set parent($rev) [join [lrange $alist 0 [expr {$alength - 3}]] "."]
          #gen_log:log D " parent $parent($rev)"
          set parentbranch [join [lrange $alist 0 [expr {$alength - 5}]] "."]
          #gen_log:log D " parentbrancch $parentbranch"
          set branchnum       [lindex $alist [expr {$alength - 4}]]
          set branchparent [join [list $parentbranch 0 $branchnum] "."]
          #gen_log:log D " branchparent $branchparent"
          if {$isodd > 0} {
            set parent($rev) [join [lrange $alist 0 [expr {$alength - 2}]] "."]
            #gen_log:log D " parent $parent($rev)"
          }
          if {[string length $parentbranch] > 0} {
          gen_log:log D "set parent parent($rev)"
            set parent($rev) $branchparent
            lappend children($branchparent) $rev
          } else {
            lappend children($parent($rev)) $rev
          }
          # Add to new list of nodes
          if {[lsearch -exact $revlist $parent($rev)] < 0 && \
              [lsearch -exact $treelist $parent($rev)] < 0 } {
            lappend treelist $parent($rev)
            gen_log:log D " add parent $parent($rev) of $rev"
          }
        }
        # Do it all over again for the new ones we added
        foreach rev $treelist {
          gen_log:log D "new $rev"
          # Find its parent
          set alist [split $rev "."]
          set alength [llength $alist]
          set isodd [expr {$alength % 2}]
          set parent($rev) [join [lrange $alist 0 [expr {$alength - 3}]] "."]
          #gen_log:log D " parent $parent($rev)"
          set parentbranch [join [lrange $alist 0 [expr {$alength - 5}]] "."]
          #gen_log:log D " parentbrancch $parentbranch"
          set branchnum       [lindex $alist [expr {$alength - 4}]]
          set branchparent [join [list $parentbranch 0 $branchnum] "."]
          #gen_log:log D " branchparent $branchparent"
          if {$isodd > 0} {
            set parent($rev) [join [lrange $alist 0 [expr {$alength - 2}]] "."]
            #gen_log:log D " parent $parent($rev)"
          }
          if {[string length $parentbranch] > 0} {
          gen_log:log D "set parent parent($rev)"
            set parent($rev) $branchparent
            lappend children($branchparent) $rev
          } else {
            lappend children($parent($rev)) $rev
          }
        }
        set treelist [concat $revlist $treelist]
        set treelist [lsort -command sortrevs $treelist]

        # Now prepare to draw the revision tree
        # Root first
        set y $cvscanv(space)
        set px(0) 10
        set x [font measure {Helvetica -12 bold} \
           -displayof $joincanvas.canvas $cvscfg(mergetrunkname)]

        set px(1) [expr {$px(0) + $x / 2}]
        set py(1) [expr {$cvscanv(boxy) - 4}]

        $joincanvas.canvas create text \
           $px(1) $y \
           -text "ROOT" \
           -anchor n -fill black \
           -font {Helvetica -12 bold}

        # Then the rest
        foreach rev $treelist {
          gen_log:log D "$rev"
          if {[info exists children($rev)]} {
            foreach r $children($rev) {
              gen_log:log D "\tparent of $r"
            } 
            set nchildren($rev) [llength $children($rev)]
            set kids [array names children $rev.*]
            foreach kid $kids {
              set descendents $children($kid)
              set ndescendents [llength $descendents]
              gen_log:log D "\tgranchildren: $descendents"
              incr nchildren($rev) $ndescendents
            }
          } else {
            set nchildren($rev) 0
          }
          gen_log:log D "\t$nchildren($rev) descendents"
          if {[info exists parent($rev)]} {
            gen_log:log D "\tchild of $parent($rev)"
          }

          set alist [split $rev "."]
          set alength [llength $alist]
          # Round up instead of down
          set ind [expr {($alength +1)/ 2}]
          set pind [expr {$ind - 1}]

          if {! [info exists py($ind)]} {
            gen_log:log D "  starting new column $ind"
            set py($ind) $cvscanv(space)
            set px($ind) [expr {$px($pind) + $cvscanv(midx) + $cvscanv(space)}]
          }
          if {[info exists parent($rev)] && $parent($rev) != ""} {
            gen_log:log D "  this one has a parent in col >=1"
            if {[info exists ylevel($parent($rev))] && $py($ind) > $ylevel($parent($rev))} {
              gen_log:log D "  jumping to level of parent"
              set py($ind) $ylevel($parent($rev))
              if {$ind > 2} {
                # Give it a node if its parent isn't in column1
                incr ylevel($parent($rev)) -$cvscanv(space)
                set px($ind) [expr {$px($pind) + $cvscanv(boxx) + $cvscanv(space)}]
                set py($ind) $ylevel($parent($rev))
                node $joincanvas $rev \
                  [expr {$px($pind) + $cvscanv(midx)}] \
                  [expr {$py($ind) - 1}]
              }
            } else {
              gen_log:log D "  parent not higher"
              set py($ind) [expr {$py($ind) - $cvscanv(space)}]
            }
            set xlevel($rev) [expr {$px($ind) + $cvscanv(midx)}]
          } else {