aegis-tk 4.24.3-3 / usr / bin / tkaepa

#!/bin/sh
#-*-tcl-*-
#
#	aegis - project change supervisor
#	Copyright (C) 2001, 2002, 2005-2008 Peter Miller
#
#	This program is free software; you can redistribute it and/or modify
#	it under the terms of the GNU General Public License as published by
#	the Free Software Foundation; either version 3 of the License, or
#	(at your option) any later version.
#
#	This program is distributed in the hope that it will be useful,
#	but WITHOUT ANY WARRANTY; without even the implied warranty of
#	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#	GNU General Public License for more details.
#
#	You should have received a copy of the GNU General Public License
#	along with this program. If not, see
#	<http://www.gnu.org/licenses/>.
#
#	script/tkaepa.  Generated from tkaepa.in by configure.
#
# comments wrap in Tcl, but not in sh \
exec wish $0 ${1+"$@"}

set bindir /usr/bin
set libdir /usr/share/aegis
set datadir /usr/share/aegis
set datarootdir /usr/share/aegis

wm title . Aepa
wm iconname . Aepa
wm iconbitmap . @$datadir/aegis.icon
wm iconmask . @$datadir/aegis.mask

set proj_brief_description ""
set proj_description ""
set proj_developer_may_review 0
set proj_developer_may_integrate 0
set proj_reviewer_may_integrate 0
set proj_developers_may_create_changes 0
set proj_umask 0
set proj_minimum_change_number 0
set proj_reuse_change_numbers 0
set proj_minimum_branch_number 0
set proj_skip_unlucky 0
set proj_compress_database 0
set proj_default_test_required 0
set proj_default_test_regression_required 0
set proj_develop_end_action "goto_being_reviewed"
set proj_protect_development_directory 0
set i_am_admin 0
set who_am_i ""

proc inform { arg } {
	.info.blurb insert end $arg
	.info.blurb see end
	.info.blurb insert end "\n"
	update
}

proc read_pipe { command errok } {
    set data ""
    set fd [open $command r]
    if { $fd != "" } {
       	set data [read $fd]
       	set codevar ""
       	catch { close $fd } codevar
       	if { $codevar != "" && !$errok } {
	    inform [format "Command \"%s\"\nreturned \"%s\"" $command $codevar]
       	}
    }
    return [string trim $data]
}

proc command_option_menu { w varName cmd firstValue args } {
	upvar #0 $varName var

	if {![info exists var]} {
		set var $firstValue
	}
	menubutton $w \
		-textvariable $varName \
		-indicatoron 1 \
		-menu $w.menu \
		-relief raised \
		-bd 2 \
		-highlightthickness 2 \
		-anchor c \
		-direction flush
	menu $w.menu -tearoff 0
	$w.menu add radiobutton -label $firstValue -variable $varName
	foreach i $args {
		$w.menu add radiobutton -label $i -variable $varName \
			-command $cmd
	}
	return $w.menu
}

proc project_drop_list { } {
	global project_name
	global project_list
	set x [winfo rootx .id.project.button]
	set y [winfo rooty .id.project.button]
	catch { destroy .popup } errcode
	toplevel .popup
	wm overrideredirect .popup 1
	wm geometry .popup +$x+$y
	listbox .popup.list -height 12 -selectmode single \
		-yscrollcommand ".popup.scroll set"
	set pos -1
	foreach pn $project_list {
		if { $pn == $project_name } { set pos [.popup.list size] }
		.popup.list insert end $pn
	}
	if { $pos >= 0 } {
		.popup.list selection set $pos
		.popup.list see $pos
	}
	scrollbar .popup.scroll -command ".popup.list yview"
	pack .popup.scroll -side right -fill y
	pack .popup.list -side left
	bind .popup.list <Double-Button-1> {
		set item [.popup.list curselection]
		if { $item != "" } { set item [.popup.list get $item] }
		if { $item != "" } {
			set project_name $item
			project_name_changed
		}
		destroy .popup
	}
}

proc project_name_changed { } {
	global project_name
	global datadir
	global proj_brief_description
	global proj_description
	global proj_developer_may_review
	global proj_developer_may_integrate
	global proj_reviewer_may_integrate
	global proj_developers_may_create_changes
	global proj_umask
	global proj_minimum_change_number
	global proj_reuse_change_numbers
	global proj_minimum_branch_number
	global proj_skip_unlucky
	global proj_compress_database
	global proj_default_test_required
	global proj_default_test_regression_required
	global proj_develop_end_action
	global proj_protect_development_directory
	global i_am_admin

	#
        # Ask Aegis for the project attributes
        #
        inform [format "Reading project %s attributes..." $project_name]
        eval [read_pipe [format "|aereport -f %s/wish/proj_attr.rpt -unf\
                -pw=1000 -project=%s" $datadir $project_name ] 0]

	set previous_admin_status $i_am_admin
        determine_admin_status

        if { $i_am_admin && !$previous_admin_status } {
            # I have now become an admin, so need to create the extra admin
            # interface bits
            create_admin_if_extras
        }

        if { !$i_am_admin && $previous_admin_status } {
            # I was an admin, so need to destroy the extra admin
            # interface bits
            destroy_admin_if_extras
        }

	#
	# Set the values of the text widgets explicitly,
	# they don't take -textvariable options.
	#
	.bdesc.text delete 1.0 end
	.bdesc.text insert end $proj_brief_description
	#.desc.text delete 1.0 end
	#.desc.text insert end $proj_description
}

proc determine_admin_status { } {
    global i_am_admin
    global who_am_i
    global project_name

    #
    # Am I an administrator?
    #
    if { $project_name != "" } {
	set proj_arg "-project $project_name"
    } else {
	set proj_arg ""
    }
    set admin_list [read_pipe \
	    [format "|aegis -list Administrators -unf %s" $proj_arg] 1]

    set i_am_admin  [expr { [lsearch -exact $admin_list $who_am_i] != -1 }]
    # puts "i_am_admin <- $i_am_admin"
}

proc dev_may_rev { } {
	global proj_developer_may_review
	global proj_develop_end_action
	if { "$proj_develop_end_action" == "goto_awaiting_integration" } {
	    if { ! $proj_developer_may_review } {
		set proj_develop_end_action "goto_being_reviewed"
	    }
	}
}

#
# Create the widget heirarchy first
#	so the user has somethign to look at while we fetch
#	the necessary information.
#
frame .id
frame .id.project
label .id.project.label -text "Project:"
pack .id.project.label -side left
button .id.project.button -textvariable project_name -command project_drop_list
pack .id.project.button -side left
pack .id.project -side left
pack .id -side top -anchor w -pady 5

frame .bdesc
label .bdesc.label -text "Brief Description:"
pack .bdesc.label -side top -anchor w
text .bdesc.text -height 1
pack .bdesc.text -side bottom -fill x
pack .bdesc -fill x

frame .bottom

set test_nor 1
set test_bas 1
set test_reg 1

frame .bottom.process

# proj_developer_may_review
checkbutton .bottom.process.dmr -text "Developer May Review" \
    -variable proj_developer_may_review -onvalue 1 -offvalue 0 \
    -command dev_may_rev
pack .bottom.process.dmr -side top -anchor w

# proj_developer_may_integrate
checkbutton .bottom.process.dmi -text "Developer May Integrate" \
    -variable proj_developer_may_integrate -onvalue 1 -offvalue 0
pack .bottom.process.dmi -side top -anchor w

# proj_reviewer_may_integrate
checkbutton .bottom.process.rmi -text "Reviewer May Integrate" \
    -variable proj_reviewer_may_integrate -onvalue 1 -offvalue 0
pack .bottom.process.rmi -side top -anchor w

# proj_develop_end_action
frame .bottom.process.dea -relief ridge -width 100 -borderwidth 2
label .bottom.process.dea.label -text "Develop End goes to:"
pack .bottom.process.dea.label -side top -anchor w

radiobutton .bottom.process.dea.gar -text "Awaiting Review" \
    -variable proj_develop_end_action -value "goto_awaiting_review"
pack .bottom.process.dea.gar -side top -anchor w
radiobutton .bottom.process.dea.gbr -text "Being Reviewed" \
    -variable proj_develop_end_action -value "goto_being_reviewed"
pack .bottom.process.dea.gbr -side top -anchor w
radiobutton .bottom.process.dea.gai -text "Awaiting Integration" \
    -variable proj_develop_end_action -value "goto_awaiting_integration" \
    -command "set proj_developer_may_review 1"
pack .bottom.process.dea.gai -side top -anchor w
pack .bottom.process.dea.gar -side top -anchor w
pack .bottom.process.dea -side left -padx 5 -pady 5 -anchor w

pack .bottom.process -side left -padx 5 -pady 5 -anchor nw

 # -----------------------------------------------------------------------
frame .bottom.misc -width 100

# proj_developers_may_create_changes
checkbutton .bottom.misc.dmcc -text "Developers May Create Changes" \
    -variable proj_developers_may_create_changes -onvalue 1 -offvalue 0
pack .bottom.misc.dmcc -side top -anchor w

# proj_default_test_required
checkbutton .bottom.misc.dtr -text "Tests Required By Default" \
    -variable proj_default_test_required -onvalue 1 -offvalue 0
pack .bottom.misc.dtr -side top -anchor w

# proj_default_test_regression_required
checkbutton .bottom.misc.dtrr -text "Regression Tests Required By Default" \
    -variable proj_default_test_regression_required -onvalue 1 -offvalue 0
pack .bottom.misc.dtrr -side top -anchor w

# proj_umask
# proj_minimum_change_number
# proj_minimum_branch_number

# proj_reuse_change_numbers
checkbutton .bottom.misc.rcn -text "Reuse Change Numbers" \
    -variable proj_reuse_change_numbers -onvalue 1 -offvalue 0
pack .bottom.misc.rcn -side top -anchor w

# proj_skip_unlucky
checkbutton .bottom.misc.su -text "Skip Unlucky Numbers" \
    -variable proj_skip_unlucky -onvalue 1 -offvalue 0
pack .bottom.misc.su -side top -anchor w

# proj_compress_database
checkbutton .bottom.misc.cdb -text "Compress Database" \
    -variable proj_compress_database -onvalue 1 -offvalue 0
pack .bottom.misc.cdb -side top -anchor w

# proj_protect_development_directory
checkbutton .bottom.misc.pdd -text "Protect Development Directory" \
	-variable proj_protect_development_directory -onvalue 1 -offvalue 0
pack .bottom.misc.pdd -side top -anchor w

pack .bottom.misc -side left -padx 5 -pady 5 -anchor nw

# -----------------------------------------------------------------------


frame .bottom.control
button .bottom.control.ok -text "OK" -bg "#BFD0BF" -command "do_it"
pack .bottom.control.ok -fill x -pady 5
button .bottom.control.apply -text "Apply" -bg "#BFD0BF" -command "apply_it"
pack .bottom.control.apply -fill x
button .bottom.control.cancel -text "Cancel" -command { exit 1 } -bg "#D0BFBF"
pack .bottom.control.cancel -fill x -pady 5
pack .bottom.control
pack .bottom.control -side right -padx 5

pack .bottom -fill x

frame .info
text .info.blurb -height 3 -yscrollcommand ".info.scroll set" -wrap word \
    -borderwidth 1
scrollbar .info.scroll -command ".info.blurb yview" -borderwidth 1
pack .info.scroll -side right -fill y
pack .info.blurb -side left -fill both -expand 1
pack .info -side bottom -fill both -expand 1

#
# Ask Aegis for the list of projects names.  We use a specialized report
# script which emits TCL code to set the project_list variable.
#
inform "Reading list of projects..."
eval [read_pipe [format "|aereport -f %s/wish/proj_list.rpt -unf\
-pw=1000" $datadir] 0]

#
# Set the project_name variable.  We need to ask Aegis for this, so that
# we get what *aegis* thinks is the default project name.
#
inform "Reading default project..."
set project_name [read_pipe "|aegis -list default_project" 1]
if { $project_name == "" } { set project_name [lindex $project_list 0] }

project_name_changed

set errorCode 0

proc apply { } {
	global test_nor test_bas test_reg
	global project_name
	global errorCode
	global proj_brief_description
	global proj_description
	global proj_developer_may_review
	global proj_developer_may_integrate
	global proj_reviewer_may_integrate
	global proj_developers_may_create_changes
	global proj_umask
	global proj_minimum_change_number
	global proj_reuse_change_numbers
	global proj_minimum_branch_number
	global proj_skip_unlucky
	global proj_compress_database
	global proj_default_test_required
	global proj_default_test_regression_required
	global proj_develop_end_action
	global proj_protect_development_directory

	set filename [format "/tmp/tkaepa-%d" [pid]]
	set errcode ""
	catch { set fd [open $filename w 0600] } errcode
	if { $fd == "" } {
		inform [format "Open %s: %s" $filename $errcode]
		set errorCode 1
		return
	}

	set proj_brief_description [.bdesc.text get 1.0 end]
	#set proj_description [.desc.text get 1.0 end]
	set tmp $proj_brief_description
	regsub -all {[\\"]} $tmp {\\&} tmp
	regsub -all \n $tmp \\n\\\n tmp
	puts $fd [format "description = \"%s\";" $tmp]

	if { $proj_developer_may_review } {
	    puts $fd "developer_may_review = true;"
	} else {
	    puts $fd "developer_may_review = false;"
	}
	if { $proj_developer_may_integrate } {
	    puts $fd "developer_may_integrate = true;"
	} else {
	    puts $fd "developer_may_integrate = false;"
	}
	if { $proj_reviewer_may_integrate } {
	    puts $fd "reviewer_may_integrate = true;"
	} else {
	    puts $fd "reviewer_may_integrate = false;"
	}
	if { $proj_developers_may_create_changes } {
	    puts $fd "developers_may_create_changes = true;"
	} else {
	    puts $fd "developers_may_create_changes = false;"
	}
	if { $proj_reuse_change_numbers } {
	    puts $fd "reuse_change_numbers = true;"
	} else {
	    puts $fd "reuse_change_numbers = false;"
	}
	if { $proj_skip_unlucky } {
	    puts $fd "skip_unlucky = true;"
	} else {
	    puts $fd "skip_unlucky = false;"
	}
	if { $proj_compress_database } {
	    puts $fd "compress_database = true;"
	} else {
	    puts $fd "compress_database = false;"
	}
	if { $proj_default_test_required } {
	    puts $fd "default_test_exemption = false;"
	} else {
	    puts $fd "default_test_exemption = true;"
	}
	if { $proj_default_test_regression_required } {
	    puts $fd "default_test_regression_exemption = false;"
	} else {
	    puts $fd "default_test_regression_exemption = true;"
	}
	puts $fd "develop_end_action = $proj_develop_end_action;"
	if { $proj_protect_development_directory } {
	    puts $fd "protect_development_directory = true;"
	} else {
	    puts $fd "protect_development_directory = false;"
	}
	close $fd

	inform [format "Setting project %s attributes..." $project_name]
	set command [list aegis -pa -f $filename -p $project_name]
	inform [format "Command = \"%s\"" $command]
	set errcode ""
	set errorCode 0
	catch { eval exec $command } errcode
	set errorCode2 $errorCode
	catch { exec rm -f $filename } errcode2
	if { $errorCode != 0 } {
		inform $errcode
	} {
		inform "   ...done"
	}
	set errorCode $errorCode2
}

proc do_it { } {
	global errorCode
	apply
	if { $errorCode == 0 } {
		exit 0
	}
}

proc apply_it { } {
	apply
}