The following Tcl code can be found in the cgi-bin/rover/irolo.tk.obj file.
# Interactive rolodex program. Uses database format of rolo.
#
# Frans Kaashoek
# 12/14/95
#
# Roverized: Anthony D. Joseph
# 1/3/96
#
#
# In addition to global variables below, irolo has a global variable "display"
# that stores the current rolodex entry. record is an array indexed by fields
# from fieldVariables. Finally, irolo maintains a global array record that
# contains all rolodex entries.
#
set fieldNames {"Name" "Work Phone" "Home Phone" "Company" "Work Address"
"Home Address" "Remarks"}
set fieldVariables {name wphone hphone company waddress haddress remarks}
set fixedFieldNames {"Last updated"}
set fixedFieldVariables {date}
#
# Standard dialog box (pp. 269 of the Tcl bible); no bitmaps, though.
#
proc dialog {w title text default args} {
global button
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
message $w.top.msg -width 3i -text $text
pack $w.top.msg -side right -expand 1 -fill both -padx 3m -pady 3m
set i 0
foreach but $args {
button $w.bot.botton$i -text $but -command "set button $i"
if {$i == $default} {
frame $w.bot.default -relief sunken -bd 1
raise $w.bot.botton$i
pack $w.bot.default -side left -expand 1 -padx 3m -pady 3m
pack $w.bot.botton$i -in $w.bot.default -side left -padx 2m \
-pady 2m -ipadx 2m -ipady 1m
} else {
pack $w.bot.botton$i -side left -expand 1 -padx 3m -pady 3m \
-ipadx 2m -ipady 1m
}
incr i
}
if {$default >= 0} {
bind $w "$w.bot.botton$default flash; set button $default"
}
set oldFocus [focus]
grab set $w
focus $w
tkwait variable button
destroy $w
focus $oldFocus
return $button
}
#
# Procedure for reporting errors to the user
#
proc errorInfo {err} {
puts stderr "ErrorInfo called with `$err'\n"
toplevel .error
frame .error.top
frame .error.bottom
label .error.text -text "Error: $err"
button .error.dismiss -text "Dismiss" \
-command "destroy .error; update; return"
button .error.quit -text "Quit" -command quitProc
pack .error.top .error.bottom -side top -fill x -padx 2m -pady 2m
pack .error.text -side left -pady 5 -in .error.top
pack .error.dismiss .error.quit -side right -fill x -padx 2m \
-pady 2m -in .error.bottom
}
#
# Create a new session. This version assumes a fixed password, but that
# could be replaced by a user query.
#
proc newSession {} {
global session env PASSWORD
if {$session == ""} {
if [catch {Rover_NewSession irolo none mh $env(USER) $PASSWORD} \
session] {
error "newSession error: $session"
}
}
}
#
# Destroy widgets for additional user fields
#
proc rolo_clean_user {} {
global display userFields
puts stderr "display(nuser) is $display(nuser)"
for {set i 0} {$i < $display(nuser)} {incr i} {
unset display($i)
unset userFields($i)
destroy .u$i
}
set display(nuser) 0
}
#
# Add a user-defined entry to the displayed rolodex entry.
#
proc rolo_addfield {} {
global display userFields
set i $display(nuser)
set display($i) ""
set userFields($i) "$i"
frame .u$i
entry .u$i.label -width 15 -relief sunken -textvariable userFields($i)
entry .u$i.u$i -width 50 -relief sunken -textvariable display($i)
pack .u$i -fill x
pack .u$i.label .u$i.u$i -side left -expand 1
incr display(nuser)
}
#
# Create an empty display for adding a new entry to the rolodex.
#
proc rolo_new {} {
global display fieldVariables fixedFieldVariables IROLOOBJ
rolo_clean_user
foreach field [concat $fieldVariables $fixedFieldVariables] {
set display($field) ""
}
}
#
# Exit rolo
#
proc rolo_exit {} {
global IROLOOBJ
if [$IROLOOBJ isDirty] {
set r [dialog .exit {Pending changes} \
{Wait for pending changes before exiting?} 0 {Yes} {No}]
if {$r == 0} {
return
}
}
exit
}
proc rolo_entryName {name} {
global user
set newname [Rover_Escape $name]
return Rover__Irolo__${user}__Entry__${newname}
}
proc rolo_commit {} {
global display fieldVariables fixedFieldVariables IROLOOBJ session \
userFields
if {[string length $display(name)] == 0} {
set r [dialog .commit {Invalid name} \
"Invalid name: \"$display(name)\"" 0 {OK}]
return
}
set found 0
set newname [rolo_entryName $display(name)]
puts stderr "Checking for duplicates of $newname\n"
foreach name [$IROLOOBJ elts] {
if [string match $newname $name] {
set found 1
set r [dialog .dup {Duplicate entry} \
{Entry exists; overwrite it?} 1 {Yes} {Stop}]
if {$r == 1} {
return
} else {
break
}
}
}
# Set date updated
set stamp [exec date]
set display(date) "Tentative: $stamp"
# Marshall the new values and user-defined fields
set result ""
foreach field [concat $fieldVariables $fixedFieldVariables] {
set result "${result}$display($field)\n"
}
for {set i 0} {$i < $display(nuser)} {incr i} {
if [info exists display($i)] {
set result "${result}$userFields($i)\n$display($i)\n"
}
}
set result [Rover_TclEscape $result]
# Now, export the change. We do the update even if the entry already
# exists in case someone else has deleted it.
set idxpromise [Rover_Export $session $IROLOOBJ \
"$IROLOOBJ commitIdx $newname" \
"Rolo-with-name $IROLOOBJ" "$IROLOOBJ commitIdxCallback $newname"]
# Create a null entry
Entry-with-name $newname ""
set epromise [Rover_Export $session $newname \
"$newname commitEntry \{$result\}" \
"Entry-with-name $newname" "$newname commitEntryCallback"]
}
#
# Delete the current entry to the rolodex.
#
proc rolo_del {} {
global display IROLOOBJ session
if {[string length $display(name)] == 0} {
set r [dialog .delete {Invalid name} \
"Invalid name: \"$display(name)\"" 0 {OK}]
return
}
set found 0
set newname [rolo_entryName $display(name)]
puts stderr "Checking for existence of $newname\n"
foreach name [$IROLOOBJ elts] {
if [string match $newname $name] {
set found 1
break
}
}
if {$found == 0} {
set r [dialog .delete {Entry not found} \
"Entry not found: \"$display(name)\"" 0 {OK}]
return
}
set r [dialog .del {Delete entry} \
{Delete this entry?} 1 {Yes} {Stop}]
if {$r == 1} return
# Now, export the change. Delete the entry from the index and the entry
# itself.
set idxpromise [Rover_Export $session $IROLOOBJ \
"$IROLOOBJ deleteIdx $newname" \
"Rolo-with-name $IROLOOBJ" "$IROLOOBJ deleteIdxCallback $newname"]
# Delete the entry
set epromise [Rover_Export $session $newname "$newname deleteEntry" \
"Entry-with-name $newname" "deleteEntryCallback $newname"]
rolo_new
}
#
# Code for manipulating a Rolodex object
#
class Rolo {ptr} {
return [$self unmarshall $ptr]
}
#
# Marshalled Rolo object format:
# []
# :
# :
#
method Rolo unmarshall {ptr} {
set count 0
while {[string length $ptr] > 0} {
set next [string first "\n" $ptr]
if {$next == -1} {
set next ""
} else {
set current [string range $ptr 0 [expr $next - 1]]
set next [string range $ptr [expr $next + 1] end]
set ptr $current
}
set slot(Names,$count) $ptr
if {[info procs $ptr] == "$ptr"} {
set slot(Status,$count) Loaded
} else {
set slot(Status,$count) "Not Loaded"
}
incr count
if {$next == ""} break
set ptr $next
}
set slot(nrecord) $count
set slot(dirty) 0
return $self
}
method Rolo commitIdxCallback {name value dv type} {
puts stderr "Index commit returned: $value ($type)"
}
method Rolo commitIdx {name {commit 0}} {
set found 0
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
if [string match $name $slot(Names,$i)] {
set found 1
if {$commit == 0} {
set slot(dirty) 1
set slot(Status,$i) "Tentative"
} else {
set slot(dirty) 0
set slot(Status,$i) "Loaded"
}
}
}
if {$found == 0} {
set slot(Names,$slot(nrecord)) $name
incr slot(nrecord)
if {$commit == 0} {
set slot(dirty) 1
set slot(Status,$slot(nrecord)) "Tentative"
} else {
set slot(dirty) 0
set slot(Status,$slot(nrecord)) "Loaded"
}
}
}
method Rolo marshall {} {
set result ""
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
set result "${result}$slot(Names,$i)\n"
}
return $result
}
method Rolo isDirty {} {
return $slot(dirty)
}
# Return the elts of a Rolo object
method Rolo elts {} {
set value {}
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
lappend value $slot(Names,$i)
}
return $value
}
#
# Scan the next record
#
method Rolo scan {} {
global nscan
rolo_clean_user
incr nscan
if {$nscan < $slot(nrecord)} {
$self display $nscan
} else {
set r [dialog .scan {Last entry} \
{No more entries; Start from beginning?} 1 {Yes} {Stop}]
if {$r == 0} {
set nscan -1
return [$self scan]
}
}
}
#
# Search for the next entry that contains n in its name field; if
# one if found, stop. Search is case insentive.
#
method Rolo search {name} {
global nscan display IROLOOBJ
rolo_clean_user
incr nscan
if {$name == ""} {
set name [string tolower $display(name)]
}
while {$nscan < $slot(nrecord)} {
if [string match *${name}* [string tolower $slot(Names,$nscan)]] {
$self display $nscan
return 1
}
incr nscan
}
set r [dialog .nf {Not found} {No matches; Start from beginning?} 1 \
{Yes} {Stop}]
if {$r == 0} {
set nscan 0
return [$IROLOOBJ search $name]
}
return 0
}
method Rolo deleteIdxCallback {name value dv type} {
puts stderr "Index delete returned: $value ($type)"
}
#
# Delete an entry in the rolodex.
#
method Rolo deleteIdx {name {commit 0}} {
set found 0
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
if [string match $name $slot(Names,$i)] {
set found 1
set slot(nrecord) [expr $slot(nrecord) - 1]
for {set j $i} {$j < $slot(nrecord)} {incr j} {
set next [expr $j + 1]
set slot(Names,$j) $slot(Names,$next)
}
unset slot(Names,$slot(nrecord))
if {$commit == 0} {
set slot(dirty) 1
} else {
set slot(dirty) 0
}
}
}
}
#
# Display a rolodex entry. Some rolodex entries have additional user-defined
# fields.
#
method Rolo display {n} {
if {($n < 0) || ($n >= $slot(nrecord))} {
error "Invalid entry index"
}
$slot(Names,$n) display
}
#
# Update the display of a rolodex entry if it is the currently displayed entry.
#
method Rolo updateDisplay {name} {
global display nscan
set current [rolo_entryName $display(name)]
puts stderr "Update $name, current is $current\n"
if [string match $current $name] {
rolo_clean_user
$name display
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
if [string match $current $slot(Names,$i)] {
set nscan $i
break
}
}
}
}
#
# Print rolodex
#
method Rolo print {} {
set fileid [open ~/.rolodex.txt w+]
foreach i [lsort -integer [TwoDArrayNames slot Names]] {
$slot(Names,$i) print $fileid
puts $fileid ""
}
close $fileid
}
############################################################################
############################################################################
############################################################################
#
#
# Code for manipulating a Entry object
#
class Entry {ptr} {
return [$self unmarshall $ptr]
}
# Format:
# [
#
# :
# :
#
#
# :
# :
#
#
# Unmarshall a rolodex record.
#
method Entry unmarshall {ptr} {
global fieldVariables fixedFieldVariables
foreach field [concat $fieldVariables $fixedFieldVariables] {
if {[string length $ptr] == 0} {
set slot($field) {}
continue
}
set next [string first "\n" $ptr]
if {$next == -1} {
set next ""
} else {
set current [string range $ptr 0 [expr $next - 1]]
set next [string range $ptr [expr $next + 1] end]
set ptr $current
}
set slot($field) $ptr
set ptr $next
if {$next == ""} break
}
# Check for user defined fields
if {[string length $ptr] == 0} {
set slot(nuser) 0
return $self
}
set i 0
set name 0
while {[string length $ptr] != 0} {
set next [string first "\n" $ptr]
if {$next == -1} {
set next ""
} else {
set current [string range $ptr 0 [expr $next - 1]]
set next [string range $ptr [expr $next + 1] end]
set ptr $current
}
if {$name == 0} {
set slot(UserFields,$i) $ptr
# Just in case the field itself is null
set slot($i) {}
incr name
} else {
set name 0
set slot($i) $ptr
incr i
}
if {$next == ""} break
set ptr $next
}
if {$name != 0} {puts stderr "WARNING! Empty user field $i"}
set slot(nuser) $i
return $self
}
method Entry commitEntryCallback {value dv type} {
puts stderr "Entry commit returned: $value ($type)"
}
method Entry commitEntry {data} {
global IROLOOBJ
$self unmarshall $data
$IROLOOBJ updateDisplay $self
}
proc deleteEntryCallback {entry value dv type} {
puts stderr "Entry delete returned: $value ($type)"
}
method Entry deleteEntry {{commit 0}} {
global session
if {$commit == 1} {
# Now we really delete the object
Rover_MarkDeleted $session $self
class_kill $self
}
}
#
# Display an rolodex entry. Some rolodex entries have additional user-defined
# fields.
#
method Entry display {} {
global display fieldVariables fixedFieldVariables label userFields
foreach field [concat $fieldVariables $fixedFieldVariables] {
set display($field) $slot($field)
}
set display(nuser) $slot(nuser)
for {set i 0} {$i < $slot(nuser)} {incr i} {
set display($i) $slot($i)
set userFields($i) $slot(UserFields,$i)
frame .u$i
entry .u$i.label -width 15 -relief sunken -textvariable userFields($i)
entry .u$i.u$i -width 50 -relief sunken -textvariable display($i)
pack .u$i -fill x
pack .u$i.label .u$i.u$i -side left -expand 1
}
}
#
# Marshall a rolodex entry
#
method Entry marshall {} {
global fieldVariables fixedFieldVariables
set result ""
foreach field [concat $fieldVariables $fixedFieldVariables] {
set result "${result}$slot($field)\n"
}
for {set i 0} {$i < $slot(nuser)} {incr i} {
if [info exists slot($i)] {
set result "${result}$slot(UserFields,$i)\n$slot($i)\n"
}
}
return [Rover_TclEscape $result]
}
#
# Pretty print rolo record
#
method Entry print {fileid} {
global fieldVariables fixedFieldVariables label userFields
set result ""
foreach field [concat $fieldVariables $fixedFieldVariables] {
puts $fileid [format "%20s : %s" $label($field) $slot($field)]
}
for {set i 0} {$i < $slot(nuser)} {incr i} {
if [info exists slot($i)] {
puts $fileid [format "%20s\t\t: %s" $slot(UserFields,$i) \
$slot($i)]
}
}
}
if {![info exists Rover__Env__serverID]} {
if {![info exists env]} {set env(USER) mosaic}
set user $env(USER)
if {![info exists session]} {set session {}}
if {![info exists PASSWORD]} {set PASSWORD foo}
if {![info exists FONT]} {set FONT -*-*-medium-r-*-*-*-120-75-*-*-*-*-*}
if [info exists Rover__Env__clientDebug] {set quiet \
$Rover__Env__clientDebug}
if {![info exists quiet]} {set quiet 0}
if {![info exists IROLOOBJ]} {set IROLOOBJ Rover__Irolo__${user}__Index}
}
proc irolo.tk.obj {{arg 0} {data 0}} {
global Rover__Env__netStatus FONT quiet IROLOOBJ fieldVariables search \
fixedFieldVariables display fieldNames fixedFieldNames nscan label
set quiet $arg
if {$quiet} {return}
#
# Layout of menu bar and buttons etc.
#
frame .mbar -relief raised -bd 2
menubutton .mbar.file -text File -menu .mbar.file.menu
menubutton .mbar.action -text Action -menu .mbar.action.menu
button .mbar.scan -text "Step" -command "$IROLOOBJ scan"
button .mbar.next -text "Search next" -command {$IROLOOBJ search $search}
pack .mbar -fill x
pack .mbar.file .mbar.action .mbar.scan .mbar.next -side left -padx 2m \
-pady 2m
# Layout file menu
menu .mbar.file.menu
.mbar.file.menu add command -label "Print rolodex" \
-command "$IROLOOBJ print"
.mbar.file.menu add command -label "Exit irolo" -command "rolo_exit"
# Layout action menu
menu .mbar.action.menu
.mbar.action.menu add command -label "New entry" -command "rolo_new"
.mbar.action.menu add command -label "New field" -command "rolo_addfield"
.mbar.action.menu add command -label "Delete entry" -command "rolo_del"
.mbar.action.menu add command -label "Commit entry" -command "rolo_commit"
#
# Layout of fields
#
set i 0
foreach field $fieldVariables {
frame .$field
set label($field) [lindex $fieldNames $i]
label .$field.label -width 15 -text $label($field)
entry .$field.$field -width 50 -relief sunken \
-textvariable display($field)
pack .$field -fill x
pack .$field.label .$field.$field -side left -expand 1
incr i
}
set i 0
foreach field $fixedFieldVariables {
frame .$field
set label($field) [lindex $fixedFieldNames $i]
label .$field.label -width 15 -text $label($field)
label .$field.$field -width 50 -textvariable display($field)
pack .$field -fill x
pack .$field.label .$field.$field -side left -expand 1
incr i
}
set display(nuser) 0
#
# Bind fields to commands
#
bind .name.name {
set search [string tolower $display(name)]
$IROLOOBJ search $search
}
if [catch {newSession;irolo_read} err] {
errorInfo $err
set env(USER) {}
set PASSWORD {}
}
catch {$IROLOOBJ display 0}
set nscan 0
set search ""
}
proc irolo_read {} {
global session IROLOOBJ user quiet
set promise [Rover_Import $session $IROLOOBJ]
if [catch {$promise claim} err] {
return [error "irolo_read error: $err"]
}
foreach name [$IROLOOBJ elts] {
set promises($name) [Rover_Import $session $name]
}
foreach name [$IROLOOBJ elts] {
$promises($name) claim
}
}