#!/usr/bin/wish
#
# tkpwdb - trivial, cross-platform password database manager
#
# dave.capella@cornell.edu - Sat Dec 21 03:26:22 EST 2002
#
# May be freely distributed and used as long as this header is retained.
# All modifications must be clearly indicated.
#
# The author makes no promise of technical support. However, bug reports,
# suggestions, questions, and comments are welcome. All will be answered
# via electronic mail as time allows.
#
# NO WARRANTY OF ANY KIND EXPRESSED OR IMPLIED. USE AT YOUR OWN RISK.
#
############################################################


############################################################
# rc4 routines - encrypt a string using the rc4 cipher
#
# i ported these (prepare_key and rc4) procedures from C 
# source posted to usenet a few years ago.
#
############################################################
proc rc4 {buf thekey} {
	set keylen [string length $thekey]

	# initialize the state table and the indexes
	#
	for { set i 0 } { $i < 256 } { incr i } { lappend state $i }
	set i1 0
	set i2 0
	
	for { set i 0 } { $i < 256 } { incr i } {

		scan [string index $thekey $i1] %c d
		set l [lindex $state $i]
		set i2 [ expr ( $d  + $l + $i2 ) % 256 ]

		# swap bytes
		set state_i [lindex $state $i]
		set state_i2 [lindex $state $i2]
		set state [lreplace $state $i $i $state_i2 ]
		set state [lreplace $state $i2 $i2 $state_i ]
		set i1 [expr ( $i1 + 1 ) % $keylen ]
	}

	# rc4 the buffer
	#
	set buflen [ string length $buf ]
	set x 0
	set y 0
	set encoded ""

	for { set i 0 } { $i < $buflen } { incr i } {

		set x [ expr ( $x + 1 ) % 256 ]
		set y [ expr ( $y + [lindex $state $x] ) % 256 ]

		# swap bytes
		set state_x [lindex $state $x]
		set state_y [lindex $state $y]
		set state [lreplace $state $x $x $state_y ]
		set state [lreplace $state $y $y $state_x ]

		# xor byte of string
		set xoridx [expr ( [lindex $state $x] + [lindex $state $y] ) % 256]
		set buf_i [ string index $buf $i ]
		scan $buf_i  %c d
		set xorval [lindex $state $xoridx]
		set newval [ expr $d ^ $xorval ]
		append encoded [ format %c $newval ]
	}

	return $encoded
}

############################################################
# ask user for password
#
proc getpwd {} {
	set w .pwdwin
	catch {destroy $w}
	toplevel $w
	wm title $w "Enter your password"

	frame $w.bf
	pack $w.bf -side bottom -fill x
	button $w.bf.bok -text OK -command { destroy .pwdwin }
	button $w.bf.bquit -text Quit -command exit
	pack $w.bf.bok -side left
	pack $w.bf.bquit -side right
	label $w.l -text Password
	pack $w.l -side bottom
	entry $w.e -textvariable thekey
	pack $w.e -side bottom

	focus $w.e
	bind .pwdwin <Return> { destroy .pwdwin }
	bind .pwdwin <Escape> { exit }
}

############################################################
# load passwords from disk
#
proc getdb {} {
	global db dbfile categories curCategory thekey signature

	set fd [ open $dbfile r ]
	fconfigure $fd -translation binary
	set buf [ read $fd ]
	close $fd

	set encoded [rc4 $buf $thekey]

	set db {}
	set categories {}

	foreach line [ split $encoded "\n" ] {
		if { [ string length $line ] } {
			lappend db $line
			if { ! [string equal $line $signature] } {
				lappend categories [ lindex [ split $line : ] 0 ]
			}
		}
	}

	# check for correct password by looking for our signature
	# on the first line. exit if not found.
	if [ expr ! [ string equal $signature [lindex $db 0] ] ] {
		msg "Cannot use $dbfile."
		tkwait window .msgwin
		exit
	}
	# discard the signature to make subsequent processing easier
	set db [lreplace $db 0 0]

	set categories [ lsort -unique -dictionary $categories ]
	set curCategory [ lindex $categories 0 ]
	return $db
}

############################################################
# write passwords to disk
#
proc putdb {} {
	global db dbfile thekey signature

	# insert a signature that we can test for successful decryption
	# when we reopen the file
	#
	set buf "$signature\n"

	# add the data for each record
	#
	foreach line $db {
		if [ string length $line ] {
			append buf "$line\n"
		}
	}

	# encrypt and write to disk
	#
	set encoded [rc4 $buf $thekey]

	set fd [ open $dbfile w ]
	fconfigure $fd -translation binary
	puts -nonewline $fd $encoded
	close $fd
}

############################################################
# view and edit passwords - main window
#
proc listwin {} {
	global db categories curCategory listbox_map listbox_cursel item lb_list

	eval destroy [winfo children .]

	menubutton .cats -text Category -relief raised -menu .cats.m
	menu .cats.m -tearoff 0
	.cats.m add command -label "All" -command "set curCategory All ; listwin"
	foreach cat $categories {
		.cats.m add command -label "$cat" -command "set curCategory $cat ; listwin"
	}
	pack .cats -side top

	frame .bf -height 150 -width 200
	pack .bf -side right -fill x -pady 2m

	button .bf.bv -text View -command  {
		set selection [.frame.list curselection]
		if [expr [llength $selection] == 1 ] {
			set idx [lindex $listbox_map $selection]
			set item [lindex $db $idx]
			showrec View
			tkwait window .recwin
			listwin
		}
	}
	pack .bf.bv -side top -fill x
	button .bf.ba -text Add -background bisque -command  {
		set item {}
		showrec Add
		tkwait window .recwin
		lappend db $item
		listwin
	}
	pack .bf.ba -side top -fill x
	button .bf.be -text Edit -background bisque -command  {
		set selection [.frame.list curselection]
		if [expr [llength $selection] == 1 ] {
			set idx [lindex $listbox_map $selection]
			set item [lindex $db $idx]
			showrec Edit
			tkwait window .recwin
			set db [lreplace $db $idx $idx $item]
			listwin
		}
	}
	pack .bf.be -side top -fill x
	button .bf.bd -text Delete -background bisque -command  {
		set selection [.frame.list curselection]
		if [expr [llength $selection] == 1 ] {
			set idx [lindex $listbox_map $selection]
			set db [lreplace $db $idx $idx]
			listwin
		}
	}
	pack .bf.bd -side top -fill x
	button .bf.bs -text Save -command putdb
	pack .bf.bs -side top -fill x
	button .bf.bp -text Password -command changekey
	pack .bf.bp -side top -fill x
	button .bf.bq -text Quit -background bisque -command exit
	pack .bf.bq -side top -fill x

	frame .frame -borderwidth .5c
	pack .frame -side right -expand yes -fill y

	scrollbar .frame.scroll -command ".frame.list yview"
	listbox .frame.list -yscroll ".frame.scroll set" -setgrid 1 -height 12 \
		-background white -selectmode single -listvar lb_list
	pack .frame.scroll -side right -fill y
	pack .frame.list -side left -expand 1 -fill both


	fill_listbox

	bind .frame.list <Double-Button-1>  { 
		set selection [.frame.list curselection]
		if [expr [llength $selection] == 1 ] {
			set idx [lindex $listbox_map $selection]
			set item [lindex $db $idx]
			showrec View
			tkwait window .recwin
			listwin
		}
	}
	bind .frame.list <<ListboxSelect>>  { set listbox_cursel [%W curselection] }

}

############################################################
# insert category of entries into list box from db
#
proc fill_listbox {} {
	global db curCategory listbox_map categories lb_list

	set db_idx 0
	set categories {}
	set listbox_map {}
	set lb_list {}

	foreach item $db {
		set fields [ split $item : ]
		# only insert items in the current category or 'All'
		if {[string equal [ lindex $fields 0 ] $curCategory ] || \
			[string equal "All" $curCategory]} {
#			set s "[lindex $fields 1]:[lindex $fields 2]"
#			lappend lb_list $s
			lappend lb_list [lindex $fields 1]
			lappend listbox_map $db_idx
		}
		# generate the list of categories from the first field
		lappend categories [ lindex $fields 0 ]

		incr db_idx
	}
	set categories [ lsort -unique -dictionary $categories ]
}

############################################################
# view and edit passwords - main window
#
proc showrec {mode} {
	global db dbfile category system account password
	global notes categories curCategory tcl_platform item

	catch {destroy .recwin}
	toplevel .recwin
	wm title .recwin "tkpwd: Record"

	set fields [split $item :]
	
	frame .recwin.buttons
	pack .recwin.buttons -side bottom -fill x -pady 2m
	button .recwin.buttons.ok -text Okay -command {
		set cat [.recwin.category.entry get]
		set sys [.recwin.system.entry get]
		set acct [.recwin.account.entry get]
		set pwd [.recwin.password.entry get]
		set note [.recwin.notes.entry get]
		set item "$cat:$sys:$acct:$pwd:$note"
		destroy .recwin
		return $item
		}
	pack .recwin.buttons.ok -side top -expand 1

	frame .recwin.category -bd 2
	entry .recwin.category.entry -relief sunken -width 40
	.recwin.category.entry insert 0 [lindex $fields 0]
	label .recwin.category.label -text Category
	pack .recwin.category.entry -side right
	pack .recwin.category.label -side left

	frame .recwin.system -bd 2
	entry .recwin.system.entry -relief sunken -width 40
	.recwin.system.entry insert 0 [lindex $fields 1]
	label .recwin.system.label -text System
	pack .recwin.system.entry -side right
	pack .recwin.system.label -side left

	frame .recwin.account -bd 2
	entry .recwin.account.entry -relief sunken -width 40
	.recwin.account.entry insert 0 [lindex $fields 2]
	label .recwin.account.label -text Account
	pack .recwin.account.entry -side right
	pack .recwin.account.label -side left

	frame .recwin.password -bd 2
	entry .recwin.password.entry -relief sunken -width 40
	.recwin.password.entry insert 0 [lindex $fields 3]
	label .recwin.password.label -text Password
	pack .recwin.password.entry -side right
	pack .recwin.password.label -side left

	frame .recwin.notes -bd 2
	entry .recwin.notes.entry -relief sunken -width 40
	.recwin.notes.entry insert 0 [lindex $fields 4]
	label .recwin.notes.label -text Notes
	pack .recwin.notes.entry -side right
	pack .recwin.notes.label -side left

	if [string equal $mode View] {
		.recwin.category.entry configure -state disabled -relief ridge
		.recwin.system.entry configure -state disabled -relief ridge
		.recwin.account.entry configure -state disabled -relief ridge
		.recwin.password.entry configure -state disabled -relief ridge
		.recwin.notes.entry configure -state disabled -relief ridge
	}

	pack .recwin.category .recwin.system .recwin.account .recwin.password .recwin.notes \
		-side top -fill x

	focus .recwin.category.entry
}

############################################################
# change passphrase used as key
#
proc changekey {} {
	set w .change
	catch {destroy $w}
	toplevel $w
	wm title $w "Enter a new password"

	frame $w.bf
	pack $w.bf -side bottom -fill x
	button $w.bf.bok -text OK -command { destroy .change ; putdb ; \
		msg "Password changed. File updated." }
	button $w.bf.bcancel -text Cancel -command { destroy .change }
	pack $w.bf.bok -side left
	pack $w.bf.bcancel -side right
	label $w.l -text Password
	pack $w.l -side bottom
	entry $w.e -textvariable thekey
	pack $w.e -side bottom

	focus $w.e
	bind .change <Return> { destroy .change ; putdb ; \
		msg "Password changed. File updated." }
	bind .change <Escape> { destroy .change }
}

############################################################
# display a message in a window
#
proc msg { txt } {
	catch { destroy .msgwin }
	toplevel .msgwin
	label .msgwin.l -text $txt
	button .msgwin.b -text ok -command { destroy .msgwin }
	pack .msgwin.l .msgwin.b
}

#####################################################################
# globals
# i know, ya ain't s'posed ta, but this is a tiny program, after all.
#
set signature "Category:System:Account:Password:Notes"
set db {}
set categories {}
set curCategory ""
set thekey ""
set listbox_map {}
set item {}
set lb_list {}

############################################################
# main
############################################################

# this prevents an empty window from popping up
# while we prompt for a password
#
wm withdraw .

# for the ipaq - it's a small screen.
# 
if { $tcl_platform(machine) == "armv4l" } {
	option add "*Font" "-*-*-*-*-*-*-7-*-*-*"
}

# but see if it's overridden on the command line
# we accept 3 cases:
# 1. no args - use default file, .tkpwdbrc, in $HOME
# 2. 1 arg - file name to open
# 3. 2 args - "-c filename", create new file
#
if { $argc } {
	if [ string equal [lindex $argv 0] "-c" ] {
		set dbfile [lindex $argv 1]
		set db $signature
		set thekey "password"
		putdb
	} else {
		if [ expr ! [ file isfile $argv ] ] {
			msg "Cannot use the file: $argv"
			tkwait window .msgwin
			exit
		} else {
			set dbfile $argv
		}
	}
} else {
	# initialize the default location for the data file
	#
	if { $tcl_platform(os) == "Windows NT" } {
		set dbfile [file join $env(HOMEDRIVE) $env(HOMEPATH) .tkpwdbrc]
	} elseif { $tcl_platform(os) == "macintosh" } {
		set dbfile [file join $env(PREF_FOLDER) tkpwdbrc]
	} else {
		set dbfile [file join $env(HOME) .tkpwdbrc]
	}
}

getpwd
tkwait window .pwdwin
if { ! [ string length $thekey ] } { exit }
wm deiconify .
set db [ lsort -dictionary [ getdb ] ]
listwin