#!/usr/local/bin/wish -f
# jpeople - manage database of people, including Mail, elm, and MH aliases
# 
# Copyright 1993-1994 by Jay Sekora.  All rights reserved, except 
# that this file may be freely redistributed in whole or in part 
# for nonprofit, noncommercial use.

catch {tk colormodel . color}		;# colour even on a 2-bit display

global VERSION
set VERSION {3.2/0.5}

######################################################################
# BASIC INITIALISATION - VARIABLES AND USER CONFIGURATION
######################################################################

# misc:
#
global NAME			;# user's login name
global HOME			;# user's home directory

global PREFS PEOPLEPREFS	;# user preferences

set PEOPLEPREFS(tag,0) "Work"
set PEOPLEPREFS(tag,1) "List"
set PEOPLEPREFS(tag,2) "Trivia"
set PEOPLEPREFS(tag,3) "Org."
set PEOPLEPREFS(tag,4) ""
set PEOPLEPREFS(tag,5) ""
set PEOPLEPREFS(tag,6) ""
set PEOPLEPREFS(tag,7) "Alt."

set NAME $env(USER)
set HOME $env(HOME)

set PEOPLEPREFS(rcfile) $HOME/.people
set PEOPLEPREFS(elmfile) $HOME/.elm/aliases.text
set PEOPLEPREFS(mhfile) $HOME/mh/aliases
set PEOPLEPREFS(mailfile) $HOME/.mailrc

set tk_strictMotif 1

# check for $HOME/.tk/jlibrary.tcl and read it in if it exists.
# this contains library procedures.  it would normally be in $tk_library,
# but we check for its presence here for people who can't put things in
# $tk_library.
#
if {[file isfile "$HOME/.tk/jlibrary.tcl"]} then {
  source "$HOME/.tk/jlibrary.tcl"
}
j:source_config jrichtext.tcl
j:source_config jabout.tcl
j:source_config jbindings.tcl

# read in user's text bindings (mainly for Entry widgets):
j:source_config -directory $HOME .textbindings.tcl

######################################################################

wm withdraw .

global mkglobals
set mkglobals {
  global ALIAS EMAIL FIRST LAST BIRTHDATE PHONE ADDRESS COMMENT TAGS
  global alias email first last phone address birthdate comment tags
  global env HOME USER PREFS PEOPLEPREFS LIMITPATTERN
}
eval $mkglobals

######################################################################
# PROCEDURE DEFINITIONS
######################################################################

# person id list - enter a person into the list.  usage is:
# person Jay_Sekora {
#   alias     {js jay sekora jays}
#   email     js@it.bu.edu
#   first     Jay
#   last      Sekora
#   phone     617/397-6653
#   address   {33 Park Street #44; Malden, MA 02148}
#   birthdate 1966.08.26
#   comment   {author of the jpeople program}
#   tags      {0 3 4 7}
# }
# ...but no checking is currently done on the first word of each pair.
#   
proc person {id list} {
  global mkglobals
  eval $mkglobals
  
  set ALIAS($id) [lindex $list 1]
  set EMAIL($id) [lindex $list 3]
  set FIRST($id) [lindex $list 5]
  set LAST($id) [lindex $list 7]
  set PHONE($id) [lindex $list 9]
  set ADDRESS($id) [lindex $list 11]
  set BIRTHDATE($id) [lindex $list 13]
  set COMMENT($id) [lindex $list 15]
  for {set i 0} {$i < 8} {incr i} {
    set TAGS($id,$i) 0
  }
  if {[llength $list] > 16} {
    foreach i [lindex $list 17] {
      set TAGS($id,$i) 1
    }
  }
}

######################################################################
# merge ?filename? - merge in a file (specified or $PEOPLEPREFS(rcfile))
######################################################################

proc merge {{filename {}}} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  if {$filename == {}} {
    set filename $PEOPLEPREFS(rcfile)
  }

  if {![file exists $filename]} then {
    return -1
  } else {
    source $filename
  }
  updatelist
}

######################################################################
# save ?filename? - write native-format output (default to $PEOPLEPREFS(rcfile))
######################################################################

proc save {{filename {}}} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  if {$filename == {}} {
    set filename $PEOPLEPREFS(rcfile)
  }
  
  set file [open $filename {w}]
  foreach id [lsort [array names ALIAS]] {
    puts $file "person $id {"
    puts $file "  [list alias:::: $ALIAS($id)]"
    puts $file "  [list email:::: $EMAIL($id)]"
    puts $file "  [list first:::: $FIRST($id)]"
    puts $file "  [list last::::: $LAST($id)]"
    puts $file "  [list phone:::: $PHONE($id)]"
    puts $file "  [list address:: $ADDRESS($id)]"
    puts $file "  [list birthdate $BIRTHDATE($id)]"
    puts $file "  [list comment:: $COMMENT($id)]"
    
    set taglist ""
    for {set i 0} {$i < 8} {incr i} {
      if $TAGS($id,$i) {lappend taglist $i}
    }
    puts $file "  [list tags::::: $taglist]"
 
    puts $file "}\n"
  }
  close $file
}

######################################################################
# load_prompt - prompt for a file to load
######################################################################

proc load_prompt {} {
  set filename [j:fs]

  if {![file exists $filename]} then {
    return -1
  } else {
    source $filename
  }
  updatelist
}

######################################################################
# save_prompt - write native-format output
######################################################################

proc save_prompt {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename [j:fs]
  
  set file [open $filename {w}]
  foreach id [lsort [array names ALIAS]] {
    puts $file "person $id {"
    puts $file "  [list alias:::: $ALIAS($id)]"
    puts $file "  [list email:::: $EMAIL($id)]"
    puts $file "  [list first:::: $FIRST($id)]"
    puts $file "  [list last::::: $LAST($id)]"
    puts $file "  [list phone:::: $PHONE($id)]"
    puts $file "  [list address:: $ADDRESS($id)]"
    puts $file "  [list birthdate $BIRTHDATE($id)]"
    puts $file "  [list comment:: $COMMENT($id)]"
    
    set taglist ""
    for {set i 0} {$i < 8} {incr i} {
      if $TAGS($id,$i) {lappend taglist $i}
    }
    puts $file "  [list tags::::: $taglist]"
 
    puts $file "}\n"
  }
  close $file
}

######################################################################
# writeelm - write elm alias format
######################################################################

proc writeelm {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename $PEOPLEPREFS(elmfile)
  
  set file [open $filename {w}]
  foreach id [lsort [array names ALIAS]] {
    foreach i_alias [lsort $ALIAS($id)] {
      puts $file \
        "$i_alias = [untex $LAST($id)]; [untex $FIRST($id)] = $EMAIL($id)"
    }
  }
  close $file
}

######################################################################
# writemh - write in mh alias format
######################################################################

proc writemh {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename $PEOPLEPREFS(mhfile)
  
  set file [open $filename {w}]
  foreach id [lsort [array names ALIAS]] {
    foreach i_alias [lsort $ALIAS($id)] {
      puts $file \
        "$i_alias: $EMAIL($id) ([untex $FIRST($id)] [untex $LAST($id)])"
    }
  }
  close $file
}

######################################################################
# writemail - write in (ucb) Mail alias format
######################################################################

proc writemail {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename $PEOPLEPREFS(mailfile)
  
  if [file isfile $filename] {
    exec mv $filename ${filename}.bak	;# save a copy
    # 					delete any existing aliases:
    exec grep -v {^alias } < ${filename}.bak > $filename
  } else {
    exec touch $filename		;# make sure it exists:
  }
  set file [open $filename {a}]
  foreach id [lsort [array names ALIAS]] {
    foreach i_alias [lsort $ALIAS($id)] {
      puts $file "alias $i_alias $EMAIL($id)"
    }
  }
  close $file
}

######################################################################
# readelm - write from elm alias format
######################################################################

proc readelm {} {
  # reads in my ~/.elm/aliases.text file and parses it.
  # assumes no group aliases
  # assumes no blank lines or comments
  global mkglobals
  eval $mkglobals

  set filename $PEOPLEPREFS(elmfile)

  if {![file exists $filename]} then {
    return -1
  } else {
    set file [open $filename {r}]
    foreach line [split [read $file] "\n"] {
      if [regexp {^#} $line] then {break}
      if [regexp {^[ 	]*$} $line] then {break}
      # strip space around equals signs:
      regsub -all { *= *} $line {=} line
      set topfields [split $line {=}]
      #
      set aliases [lindex $topfields 0]      
      set fullname [lindex $topfields 1]
      set email [lindex $topfields 2]
      #
      regsub -all { *; *} $fullname {;} fullname
      set names [split $fullname {;}]
      set last [lindex $names 0]
      set first [lindex $names 1]
      #
      set id "$first $last"
      regsub -all { } $id {_} id
      #
      regsub -all {[, ][, ]*} $aliases { } aliases
      append ALIAS($id) {}
      set ALIAS($id) [concat $ALIAS($id) $aliases]
      set EMAIL($id) $email
      set FIRST($id) $first
      set LAST($id) $last
      append BIRTHDATE($id) {}
      append PHONE($id) {}
      append ADDRESS($id) {}
      append COMMENT($id) {}
    }
  updatelist
  }
}

######################################################################
# fixtex - escape TeX special characters
#  NOTE:  this can NOT handle backslashes or braces!
######################################################################

proc fixtex {string} {
  regsub -all {[#$%^&_]} $string {\\&} string
  return $string
}

######################################################################
# untex - convert TeX accents to ASCII
######################################################################

proc untex {string} {
  regsub -all {\\i} $string {i} string		;# \i -> i
  regsub -all {\\.} $string {} string		;# \c{c} -> {c}
  regsub -all {[\{\}]} $string {} string	;# Ay{s}e -> Ayse
  return $string
}

######################################################################
# texaddresses - write TeX source file for address list
######################################################################

proc texaddresses {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename [j:fs]
  
  set file [open $filename {w}]
  puts $file {\input addresslist.def}
  foreach id [ids_by_name] {
    texentry $file $id
  }
  puts $file {\bye}
  close $file
}

######################################################################
# texphones - write TeX source file for telephone list
######################################################################

proc texphones {} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  set filename [j:fs]
  
  set file [open $filename {w}]
  puts $file {\input telephones.def}
  foreach id [ids_by_name] {
    texentry $file $id
  }
  puts $file {\bye}
  close $file
}

######################################################################
# texentry file - write one entry to TeX source file
######################################################################

proc texentry {{file stdout} id} {
  # should do error checking
  global mkglobals
  eval $mkglobals

  puts $file "% $id"
  puts $file {\\}
  puts $file [format {ln{%s}} [fixtex $LAST($id)]]
  puts $file [format {fn{%s}} [fixtex $FIRST($id)]]
  puts $file [format {ph{%s}} [fixtex $PHONE($id)]]
  puts $file [format {ad{%s}} [fixtex $ADDRESS($id)]]
  puts $file [format {em{%s}} [fixtex $EMAIL($id)]]
  puts $file [format {co{%s}} [fixtex $COMMENT($id)]]
}

######################################################################
# ids_by_name - return list of all ID's, sorted by last+first name
######################################################################

# Methodology: form a list of lists, where each sublist consists of
# the name and the corresponding id.  sort
# these.  return a list formed from the second element (id) of each
# list.
# Bugs: only considers the first word of each last name.

proc ids_by_name {} {
  global mkglobals
  eval $mkglobals

  set biglist {}
  set returnlist {}
  
  foreach id [lsort [array names LAST]] {
    lappend biglist [list [concat $LAST($id) $FIRST($id)] $id]
  }
  foreach pair [lsort $biglist] {
    lappend returnlist [lindex $pair 1]
  }
  return $returnlist  
}

######################################################################
# updatelist - update the listbox with all current information
######################################################################

proc updatelist {} {
  global mkglobals
  eval $mkglobals

  # save current scroll value (to prevent jumping to top):
  set oldyview [lindex [.people.select.sb get] 2]

  .people.select.lb delete 0 end
  foreach i [lsort [array names EMAIL]] {
    if [regexp $LIMITPATTERN $i] {
      .people.select.lb insert end $i
    }
  }

  # restore old scroll value (to prevent jumping to top):
  .people.select.lb yview $oldyview

  update
}

######################################################################
# finger - finger the currently-displayed person
######################################################################

proc finger {} {
  global mkglobals
  eval $mkglobals

  set email [.people.email.e get]
  set fingeroutput [exec finger $email]
  # deal with pesky CR-LF combination for networked finger:
  regsub -all "\r" $fingeroutput {} fingeroutput
  j:more -title "finger information for $email" -text $fingeroutput
  update
}

######################################################################
# ph - ph the currently-displayed person
######################################################################

proc ph {} {
  global mkglobals
  eval $mkglobals

  set first [.people.first.e get]
  set last [.people.last.e get]
  catch {exec ph "$first* $last" < /dev/null} fingeroutput
#  # deal with pesky CR-LF combination for networked finger:
#  regsub -all "\r" $fingeroutput {} fingeroutput
  j:more -title "ph information for $first $last" -text $fingeroutput
  update
}

######################################################################
# addchange id - add or change an alias, based on current entry contents
######################################################################

proc addchange {id} {
  global mkglobals
  eval $mkglobals
  
  if {$id == ""} {return 0}
  
  set ALIAS($id) $alias
  set EMAIL($id) $email
  set FIRST($id) $first
  set LAST($id) $last
  set PHONE($id) $phone
  set ADDRESS($id) $address
  set BIRTHDATE($id) $birthdate
  set COMMENT($id) $comment
  for {set i 0} {$i < 8} {incr i} {
    set TAGS($id,$i) $tags($i)
  }
  updatelist
}

######################################################################
# clear - clear the entries (by setting corresponding variables to {})
######################################################################

proc clear {} {
  global mkglobals
  eval $mkglobals
  global id

  set alias {}
  set email {}
  set first {}
  set last {}
  set phone {}
  set address {}
  set birthdate {}
  set comment {}
  set id {}
  for {set i 0} {$i < 8} {incr i} {
    set tags($i) 0
  }
  
  focus .people.first.e
}

######################################################################
# delete id - delete an alias
######################################################################

proc delete {id} {
  global mkglobals
  eval $mkglobals

  unset ALIAS($id)
  unset EMAIL($id)
  unset FIRST($id)
  unset LAST($id)
  unset PHONE($id)
  unset ADDRESS($id)
  unset BIRTHDATE($id)
  unset COMMENT($id)
  clear
  updatelist
}

######################################################################
# deleteall - delete all aliases
######################################################################

proc deleteall {} {
  global mkglobals
  eval $mkglobals

  foreach id [lsort [array names LAST]] {
    delete $id
  }
}

######################################################################
# deletework - delete all aliases tagged `Work'
######################################################################

proc deletework {} {
  global mkglobals
  eval $mkglobals

  foreach id [lsort [array names LAST]] {
    if {$TAGS($id,0)} {
      delete $id
    }
  }
}

######################################################################
# cmd_about - create an about box
######################################################################

proc cmd_about {} {
  global VERSION
  set about_people [format {
    j:rt:hl "jpeople"
    j:rt:cr
    j:rt:rm "by Jay Sekora, "
    j:rt:tt "js@princeton.edu"
    j:rt:par
    j:rt:rm "An address-book for X Windows."
    j:rt:cr
    j:rt:rm "Version %s."
    j:rt:par
    j:rt:rm "Copyright \251 1993-1994 by Jay Sekora.  "
    j:rt:rm "All rights reserved, except that this file may be freely "
    j:rt:rm "redistributed in whole or in part for non\255profit, "
    j:rt:rm "noncommercial use."
    j:rt:par
    j:rt:rm "If you find bugs or have suggestions for improvement, "
    j:rt:rm "please let me know.  "
    j:rt:rm "Feel free to use bits of this code in your own "
    j:rt:tt "wish"
    j:rt:rm " scripts."
  } $VERSION]
  j:about .about $about_people
  j:about:button .about {About jpeople} $about_people
  j:about:button .about {About The Author} [j:about_jay]
  j:about:button .about {About Tk and Tcl} [j:about_tktcl]
}

######################################################################
# mklist - create the listbox if it doesn't exist
######################################################################

proc mklist { {parent {}} } {
  global mkglobals
  eval $mkglobals

  if {! [winfo exists $parent.select]} {
    frame $parent.select
    listbox $parent.select.lb -relief flat -geometry 15x15 \
      -yscroll "$parent.select.sb set"
    
    scrollbar $parent.select.sb -relief flat -command "$parent.select.lb yview"
    frame $parent.select.b
    label $parent.select.b.l -anchor e -text {Limit:}
    entry $parent.select.b.e -relief sunken -width 15 \
      -textvariable LIMITPATTERN
    
    bind $parent.select.lb <1> {
      %W select from [%W nearest %y]
      set id [%W get [%W curselection]]
      set alias $ALIAS($id)
      set email $EMAIL($id)
      set first $FIRST($id)
      set last $LAST($id)
      set phone $PHONE($id)
      set address $ADDRESS($id)
      set birthdate $BIRTHDATE($id)
      set comment $COMMENT($id)
      for {set i 0} {$i < 8} {incr i} {
        set tags($i) $TAGS($id,$i)
      }
    }
    
    bind $parent.select.b.e <Return> {updatelist}

    pack append $parent.select.b \
      $parent.select.b.l {left pady 10} \
      $parent.select.b.e {left fillx pady 10} \
      [j:filler $parent.select.b] {left}
    pack append $parent.select \
      $parent.select.b {top} \
      [j:rule $parent.select] {top fillx} \
      $parent.select.lb {left expand fill} \
      [j:rule $parent.select] {left filly} \
      $parent.select.sb {left filly}
  }
  
  return $parent.select
}

######################################################################
# mkentry - handle creating each field
######################################################################

proc mkentry {{tag {}} {text {Entry:}} {next {}} {parent {}}} {
  frame $parent.people.$tag
  label $parent.people.$tag.l -anchor e -width 15 -text $text
  entry $parent.people.$tag.e -width 35 -relief sunken -textvariable $tag
  
  pack append $parent.people.$tag \
    $parent.people.$tag.l {left} \
    $parent.people.$tag.e {left expand fillx} \
    [j:filler $parent.people.$tag] {left}
  
  j:default_button .people.b.ok $parent.people.$tag.e
  
### bind $parent.people.$tag.e <Return> {addchange $id}

#  bind $parent.people.$tag.e <Tab> "focus $parent.people.$next.e"
}

######################################################################
# END OF PROCEDURE DEFINITIONS
######################################################################

toplevel .people
				;# destroying the .people toplevel quits
wm protocol .people WM_DESTROY_WINDOW {destroy .}

mklist .people			;# makes, fills frame

frame .people.menu -relief raised -borderwidth 2
menubutton .people.menu.people -text {People} -menu .people.menu.people.m
menubutton .people.menu.file -text {File} -menu .people.menu.file.m
menubutton .people.menu.person -text {Person} -menu .people.menu.person.m

menu .people.menu.people.m
.people.menu.people.m add command -label {About jpeople . . .} \
  -command {cmd_about}
.people.menu.people.m add command -label {Global Preferences . . .} \
  -command {j:global_pref_panel}
.people.menu.people.m add command -label {Issue Tcl Command . . .} \
  -command {j:prompt_tcl}
.people.menu.people.m add separator
.people.menu.people.m add command -label {Quit} -accelerator {[q]} \
  -command {destroy .}

menu .people.menu.file.m
.people.menu.file.m add command -label {Merge} -command {merge}
.people.menu.file.m add command -label {Save} -command {save}
.people.menu.file.m add command -label {Merge/Load . . .} -command {load_prompt}
.people.menu.file.m add command -label {Save . . .} -command {save_prompt}
.people.menu.file.m add separator
.people.menu.file.m add command -label {Read Elm } -command {readelm}
.people.menu.file.m add separator
.people.menu.file.m add command -label {Write Mail} -command {writemail}
.people.menu.file.m add command -label {Write Elm} -command {writeelm}
.people.menu.file.m add command -label {Write MH} -command {writemh}
.people.menu.file.m add separator
.people.menu.file.m add command -label {Write TeX Addresses . . .} -command {
  texaddresses
}
.people.menu.file.m add command -label {Write TeX Phone Numbers . . .} \
  -command {texphones}
.people.menu.file.m add separator
.people.menu.file.m add command -label {Delete All} -command {deleteall}
.people.menu.file.m add command -label {Delete Work} -command {deletework}

menu .people.menu.person.m
.people.menu.person.m add command -label {Add/Change} -command {
  addchange $id
  clear
}
.people.menu.person.m add command -label {Delete} -command {
  delete $id
}
.people.menu.person.m add command -label {Clear} -command {
  clear
}
.people.menu.person.m add separator
.people.menu.person.m add command -label {Finger} -command {finger}
.people.menu.person.m add command -label {Ph} -command {ph}

pack append .people.menu .people.menu.people left
pack append .people.menu .people.menu.file left
pack append .people.menu .people.menu.person left

mkentry first {First Name:} last
mkentry last {Last Name:} id
mkentry id {ID:} alias
bind .people.id.e <space> {.people.id.e insert insert {_}}
mkentry alias {Alias(es):} email
mkentry email {Email Address:} phone
mkentry phone {Telephone:} address
mkentry address {Address:} birthdate
mkentry birthdate {Birthdate:} comment
mkentry comment {Comment:} first

j:tab_ring \
  .people.first.e \
  .people.last.e \
  .people.id.e \
  .people.alias.e \
  .people.email.e \
  .people.phone.e \
  .people.address.e \
  .people.birthdate.e \
  .people.comment.e

frame .people.tags
frame .people.tags.filler
pack append .people.tags .people.tags.filler {left expand fillx}
for {set i 0} {$i < 8} {incr i} {
  checkbutton .people.tags.$i \
    -relief flat -text $PEOPLEPREFS(tag,$i) -variable tags($i)
  if {"x$PEOPLEPREFS(tag,$i)" != "x"} {
    pack append .people.tags .people.tags.$i {left padx 5}
  }
}

j:buttonbar .people.b -default ok -buttons {
  { ok     OK     {addchange $id; clear} }
  { delete Delete {delete $id} }
  { clear  Clear  {clear} }
  { quit   Quit   {exit 0} }
}

pack append .people \
  .people.select {left filly} \
  [j:rule .people] {left filly} \
  .people.menu {top fillx} \
  [j:filler .people] {top fillx} \
  .people.first {top expand fillx} \
  .people.last {top expand fillx} \
  .people.id {top expand fillx} \
  .people.alias {top expand fillx} \
  .people.email {top expand fillx} \
  .people.phone {top expand fillx} \
  .people.address {top expand fillx} \
  .people.birthdate {top expand fillx} \
  .people.comment {top expand fillx} \
  .people.tags {top expand fillx} \
  [j:rule .people] {top fillx} \
  .people.b {top expand fillx}

wm minsize .people 100 100
wm maxsize .people 3000 3000

focus .people.first.e

bind Entry <Meta-q> {exit 0}

# read in user's configuration file:
j:source_config jpeoplerc.tcl
# read in (shared) preferences:
j:read_standard_prefs
if {$PREFS(bindings) == "basic"} {
  j:eb:basic_bind Entry
  j:tb:basic_bind Text
} else {
  j:eb:emacs_bind Entry
  j:tb:emacs_bind Text
}

merge					;# defaults to $PEOPLEPREFS(rcfile)