cvs.tcl

来自「TKCVS Source Code For CVS。」· TCL 代码 · 共 2,270 行 · 第 1/5 页

    append mess " filespace these files which"
    append mess " have changed:\n"
  
    foreach file $filelist {
      append mess "\n\t$file"
    }
  }
  append mess "\n\nAre you sure?"
  if {[cvsconfirm $mess .workdir] == "ok"} {
    # modified by jo to build the commandline incrementally
    set commandline "$cvs update -P"
    if { $normal_binary == "Binary" } {
      append commandline " -kb"
    }
    if { $get_all_dirs == "Yes" } {
      append commandline " -d $dir"
    }
    if { $tagname != "BASE" && $tagname != "HEAD" } {
      if { $action_if_no_tag == "Remove" } {
          append commandline " -r $tagname"
      } elseif { $action_if_no_tag == "Get_head" } {
          append commandline " -f -r $tagname"
      } elseif { $action_if_no_tag == "Skip" } {
          append commandline " -s -r $tagname"
      }
    }
    if { $tagname == "HEAD" } {
      append commandline " -A"
    }
    foreach file $filelist {
      append commandline " \"$file\""
    }

    set co_cmd [viewer::new "CVS Update"]
    $co_cmd\::do $commandline 0 status_colortags
    
    if {$cvscfg(auto_status)} {
      $co_cmd\::wait
      setup_dir
    }
  }
  gen_log:log T "LEAVE"
}

proc cvs_merge {from since fromtag totag args} {
#
# This does a join (merge) of a chosen revision of localfile to the
# current revision.
#
  global cvs
  global cvscfg
  global cvsglb

  gen_log:log T "ENTER (\"$from\" \"$since\" \"$fromtag\" \"$totag\" \"$args\")"

  set filelist $args
  set v [viewer::new "CVS Join"]

  if {$since == ""} {
    set commandline "$cvs update -d -j$from $filelist"
  } else {
    set commandline "$cvs update -d -j$since -j$from $filelist"
  }
    
  $v\::do "$commandline"
  $v\::wait

  if {$cvscfg(auto_tag)} {
    set commandline "$cvs tag -F -r $from $fromtag $filelist"
    $v\::do "$commandline"
    toplevel .reminder
    wm title .reminder "Reminder"
    message .reminder.m1 -aspect 600 -text \
      "When you are finished checking in your merges, \
      you should apply the tag"
    entry .reminder.ent -width 32 -relief groove \
       -readonlybackground $cvsglb(readonlybg)
    .reminder.ent insert end $totag 
    .reminder.ent configure -state readonly
    message .reminder.m2 -aspect 600 -text \
      "using the \"Tag the selected files\" button"
    frame .reminder.bottom -relief raised -bd 2
    button .reminder.bottom.close -text "Dismiss" \
      -command {destroy .reminder}
    pack .reminder.bottom -side bottom -fill x
    pack .reminder.bottom.close -side bottom -expand yes
    pack .reminder.m1 -side top
    pack .reminder.ent -side top -padx 2
    pack .reminder.m2 -side top
  }

  if [winfo exists .workdir] {
    if {$cvscfg(auto_status)} {
      setup_dir
    }
  }
  gen_log:log T "LEAVE"
}

proc cvs_status {args} {
#
# This does a status report on the files in the current directory.
#
  global cvs
  global cvscfg

  gen_log:log T "ENTER ($args)"

  if {$args == "."} {
    set args ""
  }
  # if there are selected files, I want verbose output for those files
  # so I'm going to save the current setting here
  # - added by Jo
  set verbosity_setting ""

  busy_start .workdir.main
  set filelist [join $args]
  # if recurse option is true or there are no selected files, recurse
  set cmd_options ""
  if {! [info exists cvscfg(recurse)]} {
    set cmd_options "-l"
  }

  # if there are selected files, use verbose output
  # but save the current setting so it can be reset
  # - added by Jo
  if {[llength $filelist] > 0 || \
      ([llength $filelist] == 1  && ! [file isdir $filelist])} {
    set verbosity_setting $cvscfg(rdetail)
    set cvscfg(rdetail) "verbose"
  }

  # support verious levels of verboseness. Ideas derived from GIC
  set statcmd [exec::new "$cvs -Q status $cmd_options $filelist"]
  set raw_status [$statcmd\::output]

  if {$cvscfg(rdetail) == "verbose"} {
    view_output::new "CVS Status ($cvscfg(rdetail))" $raw_status
  } else {
    set cooked_status ""
    set stat_lines [split $raw_status "\n"]
    foreach statline $stat_lines {
      if {[string match "*Status:*" $statline]} {
        gen_log:log D "$statline"
        if {$cvscfg(rdetail) == "terse" &&\
            [string match "*Up-to-date*" $statline]} {
          continue
        } else {
          regsub {^File: } $statline {} statline
          regsub {Status:} $statline " " line
          append cooked_status $line
          append cooked_status "\n"
        }
      }
    }
    view_output::new "CVS Status ($cvscfg(rdetail))" $cooked_status
  }

  # reset the verbosity setting if necessary
  if { $verbosity_setting != "" } {
    set cvscfg(rdetail) $verbosity_setting
  }
  busy_done .workdir.main
  gen_log:log T "LEAVE"
}

proc cvs_check {directory} {
#
# This does a cvscheck on the files in the current directory.
#
  global cvs
  global cvscfg

  gen_log:log T "ENTER ($directory)"

  busy_start .workdir.main

  # The current directory doesn't have to be in CVS for cvs update to work.

  # Sometimes, cvs update doesn't work with ".", only with "" or an argument
  if {$directory == "."} {
    set directory ""
  }

  if $cvscfg(recurse) {
    set checkrecursive ""
  } else {
    set checkrecursive "-l"
  }
  set commandline "$cvs -n -q update $checkrecursive $directory"
  set check_cmd [viewer::new "CVS Directory Status Check"]
  $check_cmd\::do $commandline 1 status_colortags

  busy_done .workdir.main
  gen_log:log T "LEAVE"
}

proc cvs_checkout { dir cvsroot prune kflag revtag date target mtag1 mtag2 module } {
  #
  # This checks out a new module into the current directory.
  #
  global cvs
  global cvscfg

  gen_log:log T "ENTER ($dir $cvsroot $prune $kflag $revtag $date $target $mtag1 $mtag2 $module)"

  foreach {incvs insvn inrcs} [cvsroot_check $dir] { break }
  if {$incvs} {
    set mess "This is already a CVS controlled directory.  Are you\
              sure that you want to check out another module in\
              to this directory?"
    if {[cvsconfirm $mess .modbrowse] != "ok"} {
      return
    }
  }

  set mess "This will check out $module from CVS.\nAre you sure?"
  if {[cvsconfirm $mess .modbrowse] == "ok"} {
    if {$revtag != {}} {
      set revtag "-r \"$revtag\""
    }
    if {$date != {}} {
      set date "-D \"$date\""
    }
    if {$target != {}} {
      set target "-d \"$target\""
    }
    if {$mtag1 != {}} {
      set mtag1 "-j \"$mtag1\""
    }
    if {$mtag2 != {}} {
      set mtag2 "-j \"$mtag2\""
    }
    set v [::viewer::new "CVS Checkout"]
    set cwd [pwd]
    cd $dir
    $v\::do "$cvs -d \"$cvsroot\" checkout $prune\
             $revtag $date $target\
             $mtag1 $mtag2\
             $kflag \"$module\""
    cd $cwd
  }
  gen_log:log T "LEAVE"
  return
}

proc cvs_filelog {filename parent} {
#
# This looks at the revision log of a file.  It's called from filebrowse.tcl, 
# so we can't do operations such as merges.
#
  global cvs
  global cvscfg
  global cwd
  
  gen_log:log T "ENTER ($filename)"
  set pid [pid]
  set filetail [file tail $filename]
  
  set commandline "$cvs -d $cvscfg(cvsroot) checkout \"$filename\""
  gen_log:log C "$commandline"
  set ret [cvs_sandbox_runcmd "$commandline" cmd_output]
  if {$ret == $cwd} {
    cvsfail $cmd_output $parent
    cd $cwd
    gen_log:log T "LEAVE -- cvs checkout failed"
    return
  }

  set commandline "$cvs -d $cvscfg(cvsroot) log \"$filename\""

  # Log canvas viewer
  ::cvs_branchlog::new "CVS,rep" $filename
  cd $cwd
  gen_log:log T "LEAVE"
}

proc cvs_export { dir cvsroot kflag revtag date target module } {
#
# This exports a new module (see man cvs and read about export) into
# the current directory.
#
  global cvs
  global cvscfg 

  gen_log:log T "ENTER ($dir $cvsroot $kflag $revtag $date $target $module)"
    
  foreach {incvs insvn inrcs} [cvsroot_check $dir] { break }
  if {$incvs} { 
    set mess "This is already a CVS controlled directory.  Are you\
              sure that you want to export a module in to this directory?"
    if {[cvsconfirm $mess .modbrowse] != "ok"} {
      return
    }
  }

  set mess "This will export $module from CVS.\nAre you sure?"
  if {[cvsconfirm $mess .modbrowse] == "ok"} {
    if {$revtag != {}} {
      set revtag "-r \"$revtag\""
    }
    if {$date != {}} {
      set date "-D \"$date\""
    }
    if {$target != {}} {
      set target "-d \"$target\""
    }

    set v [::viewer::new "CVS Export"]
    set cwd [pwd]
    cd $dir
    $v\::do "$cvs -d \"$cvsroot\" export\
             $revtag $date $target $kflag \"$module\""
    cd $cwd
  }
  gen_log:log T "LEAVE"
  return
}

proc cvs_patch { cvsroot module difffmt revtagA dateA revtagB dateB outmode outfile } {
#
# This creates a patch file between two revisions of a module.  If the
# second revision is null, it creates a patch to the head revision.
# If both are null the top two revisions of the file are diffed.
#
  global cvs
  global cvscfg
 
  gen_log:log T "ENTER ($cvsroot $module $difffmt $revtagA $dateA $revtagB $dateB $outmode $outfile)"

  foreach {rev1 rev2} {{} {}} { break }
  if {$revtagA != {}} {
    set rev1 "-r \"$revtagA\""
  } elseif {$dateA != {}} {
    set rev1 "-D \"$dateA\""
  }
  if {$revtagB != {}} {
    set rev2 "-r \"$revtagB\""
  } elseif {$dateA != {}} {
    set rev2 "-D \"$dateB\""
  }
  if {$rev1 == {} && $rev2 == {}} {
    set rev1 "-t"
  }

  set commandline "$cvs -d \"$cvsroot\" patch $difffmt $rev1 $rev2 \"$module\""

  if {$outmode == 0} {
    set v [viewer::new "CVS Patch"]
    $v\::do "$commandline" 0 patch_colortags
  } else {
    set e [exec::new "$commandline"]
    set patch [$e\::output]
    gen_log:log F "OPEN $outfile"
    if {[catch {set fo [open $outfile w]}]} {
      cvsfail "Cannot open $outfile for writing" .modbrowse
      return
    }
    puts $fo $patch
    close $fo
    gen_log:log F "CLOSE $outfile"
  }
  gen_log:log T "LEAVE"
  return
}

proc cvs_version_number {} {
#
# This finds the current CVS version number.
#
  global cvs
  global cvscfg

  gen_log:log T "ENTER"
  set commandline "$cvs -v"
  set e [exec::new "$commandline" {} 0 parse_version]
  set number [$e\::output]
  regsub -all {\s*} $number {} number
  
  gen_log:log T "LEAVE ($number)"
  return $number
}

proc cvs_merge_conflict {args} {
  global cvscfg
  global cvs

  gen_log:log T "ENTER ($args)"

  set filelist [join $args]
  if {$filelist == ""} {
    cvsfail "Please select some files to merge first!"
    return
  }

  foreach file $filelist {
    # Make sure its really a conflict - tkdiff will bomb otherwise
    regsub -all {\$} $file {\$} filename
    set commandline "$cvs -n -q update \"$filename\""
    gen_log:log C "$commandline"
    catch {eval "exec $commandline"} status
    gen_log:log C "$status"

    gen_log:log F "OPEN $file"
    set f [open $file]
    set match 0
    while { [eof $f] == 0 } {
      gets $f line
      if { [string match "<<<<<<< *" $line] } {
        set match 1
        break
      }
    }
    gen_log:log F "CLOSE $file"
    close $f
   
    if { [string match "C *" $status] } {
      # If its marked "Needs Merge", we have to update before
      # we can resolve the conflict
      gen_log:log C "$commandline"
      set commandline "$cvs update \"$file\""
      gen_log:log C "$status"
      catch {eval "exec $commandline"} status
    } elseif { $match == 1 } { 
      # There are conflict markers already, dont update
      ;
    } else {
      cvsfail "This file does not appear to have a conflict." .workdir
      return
    }
    # Invoke tkdiff with the proper option for a conflict file
    # and have it write to the original file
    set commandline "$cvscfg(tkdiff) -conflict -o \"$filename\" \"$filename\""
    gen_log:log C "$commandline"
    catch {eval "exec $commandline"} view_this
  }
  
  if {$cvscfg(auto_status)} {
    setup_dir
  }
  gen_log:log T "LEAVE"
}

proc cvs_gettaglist {filename parent} {
  global cvs
  global cvscfg
  global cwd

  set keepers ""
  set pid [pid]
  gen_log:log T "ENTER ($filename)"
  set filetail [file tail $filename]