exec.tcl

TKCVS Source Code For CVS。

      variable searchidx 1.0
      variable v_e

      viewer_window $w $title [namespace current]

      proc do { command {show_stderr {1}} {filter {}} } {
        global cvscfg
        variable w
        variable v_e

        gen_log:log T "ENTER (\"$command\" \"$show_stderr\" \"$filter\")"

        pack forget $w.close
        pack $w.stop -in $w.bottom -side right -ipadx 15

        # Send the command to the execution module
        set v_e [::exec::new $command [namespace current] $show_stderr $filter]

        gen_log:log T "LEAVE"
      }

      proc abort {} {
        variable v_e
        namespace inscope $v_e abort
      }

      proc wait {} {
        variable v_e
        namespace inscope $v_e wait
      }

      # Call this proc to write arbitrary text to the viewer
      proc log { text {texttag {}} } {
        variable w
        $w.text insert end $text $texttag 
        $w.text yview end
      }

      proc search {} {
        variable searchidx
        variable w

        set str [$w.bottom.entry get]
        set match [$w.text search -- $str $searchidx]
        if {[string length $match] > 0} {
          set length [string length $str]
          $w.text mark set insert $match
          $w.text tag add sel $match "$match + ${length}c"
          $w.text see $match
          set searchidx "$match + ${length}c"
        }
      }

      return [namespace current]
    }
  }
}

# Filters output lines from CVS
# returns the name of the tag to use when printing
# the line in the text widget
# This filter doesn't need its exec argument, but filters
# must have it because some do need it
proc status_colortags {exec line} {
  global cvscfg

  set tag default
  # Return the type of the line being output
  # Neat trick I found on clt: -> is a valid variable name!
  if {[regexp {^([PUARMCD?!]) (.*)} $line -> mode file]} {
    gen_log:log D "$line"
    gen_log:log D "mode $mode file $file"
    switch -exact -- $mode {
      U { set tag updated }
      A { set tag added }
      R { set tag removed }
      D { set tag removed }
      M { set tag modified }
      C { set tag conflict }
      P { set tag patched }
      ! { set tag warning }
      ? { set tag [expr {$cvscfg(status_filter) ? {noshow} : {unknown}}] }
      default { set tag default }
    }
  } elseif {[regexp {^cvs server: warning: .*} $line]} {
    set tag warning
  }
  gen_log:log T "LEAVE: $tag"
  return [list $tag $line]
}

proc patch_colortags {exec line} {
  global cvscfg

  gen_log:log T "ENTER ($exec \"$line\")"

  set tag default
  # Return the type of the line being output
  switch -regexp -- $line {
    { is new;}       { set tag added }
    { changed from } { set tag modified }
    { is removed;}   { set tag removed }
    {^\+}            { set tag added }
    {^\-}            { set tag removed }
    {^Index}         { set tag modified }
    default          { set tag default }
  }

  return [list $tag $line]
}

proc parse_version {exec line} {
  if {[string match "Concurrent*" $line]} {
    set version [lindex [split $line] 4]
    return [list tagged $version]
  }
  return [list {} {}]
}

proc hilight_rcslog {exec line} {
  set tag default
  if {[string match "=============*" $line]} {
    set tag patched
  } elseif  {[string match "RCS file:*" $line]} {
    set tag patched
  } elseif  {[string match "Working file:*" $line]} {
    set tag patched
  }

  return [list $tag $line]
}

# This is a plain viewer that prints whatever text is sent to it
namespace eval ::view_output {
  variable instance 0

  proc new {title text_to_display} {
    variable instance
    set my_idx $instance
    incr instance

    gen_log:log T "ENTER ($title ...)"
    namespace eval $my_idx {
      global cvscfg
      variable my_idx [uplevel {concat $my_idx}]
      variable title [uplevel {concat $title}]
      variable text_to_display [uplevel {list $text_to_display}]
      variable w ".output$my_idx"
      variable searchstr {}
      variable searchidx 1.0

      viewer_window $w $title [namespace current]

      foreach line $text_to_display {
        $w.text insert end "$line"
      }

      proc search {} {
        variable searchidx
        variable w

        set str [$w.bottom.entry get]
        set match [$w.text search -- $str $searchidx]
        if {[string length $match] > 0} {
          set length [string length $str]
          $w.text mark set insert $match
          $w.text tag add sel $match "$match + ${length}c"
          $w.text see $match
          set searchidx "$match + ${length}c"
        }
      }

    }
  }
}

proc viewer_window {w title parent} {
  global cvscfg
  global cvsglb
  global tcl_platform

  toplevel $w
  if {$tcl_platform(platform) != "windows"} {
    wm iconbitmap $w @$cvscfg(bitmapdir)/cvs-says.xbm
  }
  wm protocol $w WM_DELETE_WINDOW "$w.close invoke"

  text $w.text -setgrid yes -relief sunken -border 2 \
      -bg $cvsglb(textbg) \
      -exportselection 1 -height 30 \
      -yscroll "$w.scroll set"
  bind $w.text <KeyPress> {
    switch -- %K {
      "Up" -
      "Left" -
      "Right" -
      "Down" -
      "Next" -
      "Prior" -
      "Home" -
      "End" {}
      "c" -
      "C" {
          if {(%s & 0x04) == 0} {
            break
          }
        }
      default {
          break
        }
    }
  }
  bind $w.text <<Paste>> {break}
  bind $w.text <<Cut>> {break}

  # Configure the various tags
  foreach outputcolor [array names cvscfg outputColor,*] {
    regsub {^.*,} $outputcolor {} mode
    $w.text tag configure "$mode" -foreground $cvscfg($outputcolor)
  }

  scrollbar $w.scroll -relief sunken -command "$w.text yview"
  frame $w.bottom
  button $w.bottom.srchbtn -text Search -command "$parent\::search"
  entry $w.bottom.entry -width 20 -textvariable searchstr
  bind $w.bottom.entry <Return> "$parent\::search"
  
  button $w.save -text "Save to File" -command "save_viewcontents $w"
  button $w.close -text "Close" -command "
    namespace delete $parent
    destroy $w
    exit_cleanup 0
  "
  button $w.stop -text "Stop" -bg red4 -fg white \
      -state [expr {$cvscfg(allow_abort) ? {normal} : {disabled}}] \
      -command "$parent\::abort"
  pack $w.bottom -side bottom -fill x ;#-padx 25
  pack $w.scroll -side right -fill y
  pack $w.text -fill both -expand 1
  pack $w.bottom.srchbtn -side left
  pack $w.bottom.entry -side left
  pack $w.save -in $w.bottom -side left -padx 25
  pack $w.close -in $w.bottom -side right -ipadx 15

  # Focus to activate text bindings
  focus $w
  wm title $w "$title"
}

proc save_viewcontents {w} {
  set types  { {{All Files} *} }
  set savfile [ \
    tk_getSaveFile -title "Save Results Summary" \
       -initialdir "." \
       -filetypes $types \
       -parent $w \
  ]  
  if {$savfile == ""} {
    return
  } 
  if {[catch {set fo [open $savfile w]}]} {
    puts "Cannot open $savfile for writing"
    return
  }
  puts $fo [$w.text get 1.0 end]
  close $fo
}

#
# Search functionality for text widgets
#
proc search_textwidget_init {} {
# Initialize the globals for general text searches
  global cvsglb

  if {! [info exists cvsglb(searchstr)] } {
    set cvsglb(searchstr) ""
  }
  set cvsglb(searchidx) "1.0"
}

proc search_textwidget { wtx } {
# Search the text widget
  global cvsglb
  global cvscfg

  #gen_log:log T "ENTER ($wtx)"
  set searchstr $cvsglb(searchstr)

  set match [$wtx search -- $searchstr $cvsglb(searchidx)]
  if {[string length $match] > 0} {
    set length [string length $searchstr]
    $wtx mark set insert $match
    $wtx tag add sel $match "$match + ${length}c"
    $wtx see $match
    set cvsglb(searchidx) "$match + ${length}c"
  }
}