зеркало из https://github.com/mozilla/pjs.git
753 строки
18 KiB
Tcl
Executable File
753 строки
18 KiB
Tcl
Executable File
# -*- Mode: tcl; indent-tabs-mode: nil -*-
|
|
#
|
|
# The contents of this file are subject to the Netscape Public License
|
|
# Version 1.0 (the "License"); you may not use this file except in
|
|
# compliance with the License. You may obtain a copy of the License at
|
|
# http://www.mozilla.org/NPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS"
|
|
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
|
|
# License for the specific language governing rights and limitations
|
|
# under the License.
|
|
#
|
|
# The Original Code is the Bonsai CVS tool.
|
|
#
|
|
# The Initial Developer of the Original Code is Netscape Communications
|
|
# Corporation. Portions created by Netscape are Copyright (C) 1998
|
|
# Netscape Communications Corporation. All Rights Reserved.
|
|
|
|
# What some of the global variables mean:
|
|
# lastgoodtimestamp -- the timestamp when we last knew we had a good tree.
|
|
# closetimestamp -- when the tree was closed. When we open, it probably
|
|
# becomes the lastgoodtimestamp
|
|
|
|
set cvscommand /tools/ns/bin/cvs
|
|
set rlogcommand /tools/ns/bin/rlog
|
|
set rcsdiffcommand /tools/ns/bin/rcsdiff
|
|
set cocommand /tools/ns/bin/co
|
|
set sendmailcommand /usr/lib/sendmail
|
|
set lxr_base http://cvs-mirror.mozilla.org/webtools/lxr/source
|
|
set mozilla_lxr_kludge TRUE
|
|
|
|
set cvsadmin terry@mozilla.org
|
|
set userdomain nowhere.nowhere
|
|
set mysqluser nobody
|
|
set mysqlpassword ""
|
|
|
|
set ldapserver nsdirectory.netscape.com
|
|
set ldapport 389
|
|
|
|
|
|
if {![info exists env(TZ)] || [cequal $env(TZ) ""]} {
|
|
# Shouldn't have to do this! Something busted on warp, I think.
|
|
set env(TZ) PST8PDT
|
|
}
|
|
|
|
|
|
# BUGSYSTEMEXPR is something that may be redefined in data/configdata, which
|
|
# will define what to use in the replacement part of a regsub to quote bug
|
|
# numbers that appear in the system.
|
|
set BUGSYSTEMEXPR {<A HREF="http://scopus/bugsplat/show_bug.cgi?id=&">&</A>}
|
|
set treeid {default}
|
|
|
|
|
|
if {[info exists tcl_version] && $tcl_version >= 8.0} {
|
|
# The below tclX functions moved into the main TCL codebase in version 8,
|
|
# but their names changed. So, we cope. Note that these conversion
|
|
# routines only cover Bonsai's current use of these routines, not all
|
|
# possible uses.
|
|
proc getclock {} {
|
|
return [clock seconds]
|
|
}
|
|
proc convertclock {str args} {
|
|
if {[lindex $args 0] == "GMT"} {
|
|
return [clock scan $str -gmt 1]
|
|
}
|
|
return [clock scan $str]
|
|
}
|
|
# proc fmtclock {date args} {
|
|
# }
|
|
}
|
|
|
|
|
|
|
|
proc NOTDEF {foo} {
|
|
}
|
|
|
|
|
|
proc ConnectToDatabase {} {
|
|
global mysqlhandle mysqluser mysqlpassword
|
|
if {![info exists mysqlhandle]} {
|
|
if { $mysqlpassword == "" } {
|
|
if { $mysqluser == "" } {
|
|
set mysqlhandle [mysqlconnect]
|
|
} else {
|
|
set mysqlhandle [mysqlconnect -user "$mysqluser"]
|
|
}
|
|
} else {
|
|
set mysqlhandle [mysqlconnect -user "$mysqluser" -password "$mysqlpassword"]
|
|
}
|
|
mysqluse $mysqlhandle "bonsai"
|
|
}
|
|
}
|
|
|
|
proc DisconnectFromDatabase {} {
|
|
global mysqlhandle
|
|
if {[info exists mysqlhandle]} {
|
|
mysqlclose $mysqlhandle
|
|
unset mysqlhandle
|
|
}
|
|
}
|
|
|
|
|
|
proc SendSQL { str } {
|
|
# puts $str
|
|
global mysqlhandle errorInfo
|
|
if {[catch {mysqlsel $mysqlhandle $str} errmsg]} {
|
|
puts $str
|
|
error "$errmsg - $str" $errorInfo
|
|
}
|
|
return 0
|
|
}
|
|
|
|
proc MoreSQLData {} {
|
|
global mysqlhandle
|
|
set result [mysqlresult $mysqlhandle "rows?"]
|
|
return [expr ![cequal $result ""] && $result > 0]
|
|
}
|
|
|
|
proc FetchSQLData {} {
|
|
global mysqlhandle
|
|
return [mysqlnext $mysqlhandle]
|
|
}
|
|
|
|
proc SqlQuote {str} {
|
|
regsub -all "'" $str "''" str
|
|
#
|
|
# This next line is quoting hell. One level of quoting comes from
|
|
# the TCL interpreter, and another level comes from TCL's regular
|
|
# expression parser. It really works out to "change every
|
|
# backslash to two backslashes".
|
|
regsub -all "\\\\" $str "\\\\\\\\" str
|
|
|
|
return $str
|
|
}
|
|
|
|
|
|
# proc GetId {table field value} {
|
|
# global lastidcache
|
|
# if {[info exists lastidcache($table)]} {
|
|
# lassign lastidcache($table) cval id
|
|
# if {[cequal $value $cval]} {
|
|
# return $id
|
|
# }
|
|
# }
|
|
# set qvalue [SqlQuote $value]
|
|
# SendSQL "select id from $table where $field = '$qvalue'"
|
|
# set result [lindex [FetchSQLData] 0]
|
|
# if {[cequal $result ""]} {
|
|
# SendSQL "insert into $table ($field) values ('$qvalue')"
|
|
# SendSQL "select LAST_INSERT_ID()"
|
|
# set result [lindex [FetchSQLData] 0]
|
|
# }
|
|
# set lastidcache($table) [list $value $result]
|
|
# return $result
|
|
# }
|
|
|
|
proc GetId {table field value} {
|
|
global lastidcache
|
|
if {[info exists lastidcache($table,$field,$value)]} {
|
|
set id $lastidcache($table,$field,$value)
|
|
return $id
|
|
}
|
|
set qvalue [SqlQuote $value]
|
|
SendSQL "select id from $table where $field = '$qvalue'"
|
|
set result [lindex [FetchSQLData] 0]
|
|
if {[cequal $result ""]} {
|
|
SendSQL "insert into $table ($field) values ('$qvalue')"
|
|
SendSQL "select LAST_INSERT_ID()"
|
|
set result [lindex [FetchSQLData] 0]
|
|
}
|
|
set lastidcache($table,$field,$value) $result
|
|
return $result
|
|
}
|
|
|
|
|
|
set lastdescription { }
|
|
set lastdescriptionid 0
|
|
proc AddToDatabase {lines desc} {
|
|
global lastdescription lastdescriptionid
|
|
if {[clength $desc] > 60000} {
|
|
set desc [crange $desc 0 60000]
|
|
}
|
|
set desc [string trimright $desc]
|
|
|
|
if {[cequal $desc $lastdescription]} {
|
|
set descid $lastdescriptionid
|
|
} else {
|
|
set descid {}
|
|
}
|
|
|
|
set basequery "replace into checkins(type,when,whoid,repositoryid,dirid,"
|
|
append basequery "fileid,revision,stickytag,branchid,addedlines,"
|
|
append basequery "removedlines,descid) values ("
|
|
foreach line [split $lines "\n"] {
|
|
if {[cequal $line ""]} {
|
|
continue
|
|
}
|
|
lassign [split $line "|"] chtype date name repository dir \
|
|
file version sticky branch addlines removelines
|
|
|
|
Log "line <$line> date <$date>"
|
|
regsub {^T} $branch {} branch
|
|
regsub {/$} $dir {} dir
|
|
if {[cequal $addlines ""]} {
|
|
set addlines 0
|
|
}
|
|
if {[cequal $removelines ""]} {
|
|
set removelines 0
|
|
}
|
|
if {[catch {set removelines [expr abs($removelines)]}]} {
|
|
continue
|
|
}
|
|
if {[catch {set date [fmtclock $date {%Y-%m-%d %H:%M}]}]} {
|
|
continue
|
|
}
|
|
|
|
|
|
if {[cequal $descid ""]} {
|
|
set quoted [SqlQuote $desc]
|
|
SendSQL "select distinct descid from checkins,descs where when = '$date' and descs.id = descid and descs.description = '$quoted'"
|
|
if {![MoreSQLData]} {
|
|
SendSQL "insert into descs (description) values ('$quoted')"
|
|
SendSQL "select LAST_INSERT_ID()"
|
|
}
|
|
set descid [lindex [FetchSQLData] 0]
|
|
set lastdescriptionid $descid
|
|
set lastdescription $desc
|
|
}
|
|
|
|
set query $basequery
|
|
switch $chtype {
|
|
"C" {
|
|
append query "'Change'"
|
|
}
|
|
"A" {
|
|
append query "'Append'"
|
|
}
|
|
"R" {
|
|
append query "'Remove'"
|
|
}
|
|
default {
|
|
append query "NULL"
|
|
}
|
|
}
|
|
append query ",'$date'"
|
|
append query ",[GetId people who $name]"
|
|
append query ",[GetId repositories repository $repository]"
|
|
append query ",[GetId dirs dir $dir]"
|
|
append query ",[GetId files file $file]"
|
|
append query ",'[SqlQuote $version]'"
|
|
append query ",'[SqlQuote $sticky]'"
|
|
append query ",[GetId branches branch $branch]"
|
|
append query ",$addlines"
|
|
append query ",$removelines"
|
|
append query ",$descid)"
|
|
SendSQL $query
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
proc assert {arg} {
|
|
set result [uplevel 1 expr $arg]
|
|
if {!$result} {
|
|
error "Bad assertion $arg"
|
|
}
|
|
}
|
|
set lockcount 0
|
|
|
|
|
|
proc html_quote {var} {
|
|
regsub -all {&} "$var" {\&} var
|
|
regsub -all {<} "$var" {\<} var
|
|
regsub -all {>} "$var" {\>} var
|
|
return $var
|
|
}
|
|
|
|
proc url_quote_char {c} {
|
|
scan $c "%c" value
|
|
if {$value <= 32 || [regexp {[ %=&?]} $c]} {
|
|
return [format "%%%02x" $value]
|
|
}
|
|
return $c
|
|
}
|
|
|
|
proc url_quote {var} {
|
|
set result ""
|
|
foreach c [split $var ""] {
|
|
append result [url_quote_char $c]
|
|
}
|
|
return $result
|
|
}
|
|
|
|
proc DataDir {} {
|
|
global treeid
|
|
if {[cequal $treeid "default"]} {
|
|
return data
|
|
} else {
|
|
return data/$treeid
|
|
}
|
|
}
|
|
|
|
|
|
proc Lock {} {
|
|
global lockcount lockfid
|
|
if {$lockcount <= 0} {
|
|
set lockcount 0
|
|
if {[catch {set lockfid [open "data/lockfile" "a"]}]} {
|
|
catch {mkdir data}
|
|
catch {chmod 0777 data}
|
|
set lockfid [open "data/lockfile" "a"]
|
|
}
|
|
flock -write $lockfid
|
|
catch {chmod 0666 data/lockfile}
|
|
}
|
|
incr lockcount
|
|
}
|
|
|
|
|
|
proc Unlock {} {
|
|
global lockcount lockfid
|
|
incr lockcount -1
|
|
if {$lockcount <= 0} {
|
|
funlock $lockfid
|
|
close $lockfid
|
|
}
|
|
}
|
|
|
|
|
|
proc LoadDirList {} {
|
|
global legaldirs treeid treeinfo
|
|
set legaldirs {}
|
|
|
|
if {![info exists treeinfo($treeid,repository)]} {
|
|
LoadTreeConfig
|
|
}
|
|
|
|
set modules $treeinfo($treeid,repository)/CVSROOT/modules
|
|
set dirsfile [DataDir]/legaldirs
|
|
|
|
if {[file exists $modules]} {
|
|
if {![file exists $dirsfile] ||
|
|
[file mtime $dirsfile] < [file mtime $modules]} {
|
|
catch {exec ./createlegaldirs.tcl $treeid}
|
|
}
|
|
}
|
|
|
|
Lock
|
|
for_file line $dirsfile {
|
|
lappend legaldirs $line
|
|
}
|
|
Unlock
|
|
}
|
|
|
|
|
|
proc PickNewBatchID {} {
|
|
global batchid
|
|
incr batchid
|
|
Lock
|
|
set fid [open [DataDir]/batchid "w"]
|
|
puts $fid "set batchid $batchid"
|
|
close $fid
|
|
Unlock
|
|
}
|
|
|
|
|
|
|
|
set readonly 0
|
|
|
|
proc LoadCheckins {} {
|
|
global batchid treeopen checkinlist
|
|
global lastgoodtimestamp closetimestamp
|
|
assert {![info exists checkinlist]}
|
|
Lock
|
|
if {![info exists batchid]} {
|
|
set filename "[DataDir]/batchid"
|
|
if {![file exists $filename]} {
|
|
set fid [open $filename "w"]
|
|
chmod 0666 $filename
|
|
puts $fid "set batchid 1"
|
|
close $fid
|
|
}
|
|
uplevel #0 source $filename
|
|
}
|
|
set filename [DataDir]/batch-$batchid
|
|
if {[file exists $filename]} {
|
|
uplevel #0 source $filename
|
|
}
|
|
Unlock
|
|
|
|
if {![info exists checkinlist]} {
|
|
set checkinlist {}
|
|
}
|
|
if {![info exists treeopen]} {
|
|
set treeopen 1
|
|
}
|
|
foreach t {lastgoodtimestamp closetimestamp} {
|
|
if {![info exists $t]} {
|
|
set $t [convertclock "1/1/70"]
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
proc WriteCheckins {} {
|
|
global batchid checkinlist treeopen readonly
|
|
global lastgoodtimestamp closetimestamp
|
|
if {$readonly} {
|
|
puts "<P><B><font color=red>Can't write checkins file; not viewing"
|
|
puts "current info.</font></b>"
|
|
return
|
|
}
|
|
set filename [DataDir]/temp-[id process]
|
|
set fid [open $filename "w"]
|
|
chmod 0666 $filename
|
|
# Hack to make person be an empty array:
|
|
set person(xyzzy) 1
|
|
unset person(xyzzy)
|
|
foreach i {treeopen lastgoodtimestamp closetimestamp checkinlist} {
|
|
puts $fid [list set $i [set $i]]
|
|
}
|
|
foreach c $checkinlist {
|
|
upvar #0 $c info
|
|
foreach i [lsort [array names info]] {
|
|
puts $fid [list set [set c]($i) $info($i)]
|
|
}
|
|
set person($info(person)) 1
|
|
}
|
|
close $fid
|
|
Lock
|
|
set filedest [DataDir]/batch-$batchid
|
|
if {[file exists $filedest]} {
|
|
unlink $filedest
|
|
}
|
|
frename $filename $filedest
|
|
|
|
set fid [open $filename "w"]
|
|
chmod 0666 $filename
|
|
foreach i [lsort [array names person]] {
|
|
puts $fid [EmailFromUsername $i]
|
|
}
|
|
puts $fid "bonsai-hookinterest@glacier"
|
|
puts $fid "mcom.dev.client.build.busted"
|
|
close $fid
|
|
frename $filename [DataDir]/hooklist
|
|
|
|
Unlock
|
|
}
|
|
|
|
|
|
|
|
proc ConstructMailTo {name subject} {
|
|
return "<a href=\"mailto:$name?subject=$subject\">Send mail to $name</a>"
|
|
}
|
|
|
|
|
|
|
|
proc Log {str} {
|
|
Lock
|
|
set filename "[DataDir]/logfile"
|
|
set fid [open $filename "a"]
|
|
catch {chmod 0666 $filename}
|
|
puts $fid "[fmtclock [getclock] "%D %H:%M"] $str"
|
|
close $fid
|
|
Unlock
|
|
}
|
|
|
|
|
|
proc GenerateProfileHTML {name} {
|
|
global ldapserver ldapport
|
|
foreach i {
|
|
{cn Name}
|
|
{mail E-mail}
|
|
{telephonenumber Phone}
|
|
{pager Pager}
|
|
{nscpcurcontactinfo {Contact Info}}
|
|
} {
|
|
lassign $i n t
|
|
lappend namelist $n
|
|
set title($n) $t
|
|
set value($n) ""
|
|
}
|
|
|
|
if {[catch {set fid [open "|./data/ldapsearch -b \"dc=netscape,dc=com\" -h $ldapserver -p $ldapport -s sub \"(mail=$name@netscape.com)\" $namelist" r]} errinfo]} {
|
|
return "<B>Error -- Couldn't contact the directory server.</B><PRE>$errinfo</PRE>"
|
|
}
|
|
|
|
set result "<TABLE>"
|
|
|
|
while {[gets $fid line] >= 0} {
|
|
if {[regexp -- {^([a-z]*): (.*)$} $line foo n v]} {
|
|
lappend value($n) $v
|
|
}
|
|
}
|
|
|
|
if {[catch {close $fid} errinfo]} {
|
|
return "<B>Error -- problem running ldapsearch.</B><PRE>$errinfo</PRE>"
|
|
}
|
|
|
|
foreach i $namelist {
|
|
foreach v $value($i) {
|
|
append result "<TR><TD align=right><B>$title($i):</B></TD>"
|
|
append result "<TD>$v</TD></TR>"
|
|
}
|
|
}
|
|
append result "</TABLE>"
|
|
|
|
return $result
|
|
}
|
|
|
|
|
|
proc MyFmtClock {time} {
|
|
return [fmtclock $time "%D %T"]
|
|
}
|
|
|
|
|
|
proc LoadMOTD {} {
|
|
global motd
|
|
Lock
|
|
set motd {}
|
|
if {[file exists [DataDir]/motd]} {
|
|
uplevel #0 source [DataDir]/motd
|
|
}
|
|
Unlock
|
|
}
|
|
|
|
proc WriteMOTD {} {
|
|
global motd
|
|
Lock
|
|
set fid [open [DataDir]/motd "w"]
|
|
catch {chmod 0666 [DataDir]/motd}
|
|
puts $fid [list set motd $motd]
|
|
close $fid
|
|
Unlock
|
|
}
|
|
|
|
proc LoadWhiteboard {} {
|
|
global whiteboard origwhiteboard
|
|
set whiteboard {}
|
|
Lock
|
|
if {[file exists [DataDir]/whiteboard]} {
|
|
set whiteboard [read_file [DataDir]/whiteboard]
|
|
}
|
|
Unlock
|
|
set origwhiteboard $whiteboard
|
|
}
|
|
|
|
|
|
proc WriteWhiteboard {} {
|
|
global whiteboard origwhiteboard
|
|
if {![cequal $origwhiteboard $whiteboard]} {
|
|
Lock
|
|
set filename "[DataDir]/whiteboard"
|
|
if {[file exists $filename]} {
|
|
catch {unlink $filename}
|
|
}
|
|
set fid [open $filename w]
|
|
puts $fid $whiteboard
|
|
close $fid
|
|
catch {chmod 0666 $filename}
|
|
Unlock
|
|
}
|
|
}
|
|
|
|
|
|
|
|
proc LoadTreeConfig {} {
|
|
global treelist treeinfo
|
|
Lock
|
|
set treelist {}
|
|
catch {unset treeinfo}
|
|
set filename data/configdata
|
|
if {[file exists $filename]} {
|
|
uplevel #0 source $filename
|
|
}
|
|
Unlock
|
|
}
|
|
|
|
|
|
proc Pluralize {str num} {
|
|
if {$num == 1} {
|
|
return $str
|
|
} else {
|
|
return "[set str]s"
|
|
}
|
|
}
|
|
|
|
|
|
proc MailDiffs {name oldstr newstr} {
|
|
if {[cequal $oldstr $newstr]} {
|
|
return
|
|
}
|
|
set old "data/old[set name].[id process]"
|
|
set new "data/new[set name].[id process]"
|
|
set diffs data/diffs.[id process]
|
|
set fid [open $old "w"]
|
|
puts $fid $oldstr
|
|
close $fid
|
|
set fid [open $new "w"]
|
|
puts $fid $newstr
|
|
close $fid
|
|
catch {exec diff -c -b $old $new > $diffs}
|
|
set difftext [read_file $diffs]
|
|
if {[clength $difftext] > 3} {
|
|
set text "From: bonsai-daemon
|
|
To: bonsai-messageinterest@glacier, mcom.dev.client.build.busted
|
|
Subject: [SubjectTag] Changes made to $name
|
|
Mime-Version: 1.0
|
|
Content-Type: text/plain
|
|
|
|
$difftext
|
|
"
|
|
|
|
global sendmailcommand
|
|
exec $sendmailcommand -t << $text
|
|
}
|
|
unlink $old
|
|
unlink $new
|
|
unlink $diffs
|
|
}
|
|
|
|
|
|
proc PrettyDelta {delta} {
|
|
set result ""
|
|
set oneday [expr 24*60*60]
|
|
if {$delta > $oneday} {
|
|
set numdays [$delta / $oneday]
|
|
append result " $numdays day"
|
|
if {$numdays > 1} {
|
|
append result "s"
|
|
}
|
|
set delta [expr $delta % $oneday]
|
|
}
|
|
set onehour [expr 60*60]
|
|
set numhours [expr $delta / $onehour]
|
|
if {$numhours > 0} {
|
|
append result " $numhours hour"
|
|
if {$numhours > 1} {
|
|
append result "s"
|
|
}
|
|
set delta [expr $delta % $onehour]
|
|
}
|
|
set oneminute 60
|
|
set numminutes [expr $delta / $oneminute]
|
|
if {$numminutes > 0} {
|
|
append result " $numminutes minute"
|
|
if {$numminutes > 1} {
|
|
append result "s"
|
|
}
|
|
set delta [expr $delta % $oneminute]
|
|
}
|
|
if {$delta > 0} {
|
|
append result " $delta second"
|
|
if {$delta > 1} {
|
|
append result "s"
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
|
|
# Generate a string to put at the head of a subject of an e-mail.
|
|
proc SubjectTag {} {
|
|
global treeid
|
|
if {[cequal $treeid default]} {
|
|
return {[Bonsai]}
|
|
} else {
|
|
return "\[Bonsai-$treeid\]"
|
|
}
|
|
}
|
|
|
|
|
|
# Confirm that the given password is right. If not, generate HTML and exit.
|
|
|
|
proc CheckGlobalPassword {password {encoded {}}} {
|
|
set fid [open data/passwd "r"]
|
|
set correct [string trim [read $fid]]
|
|
close $fid
|
|
|
|
if {[clength $encoded] == 0} {
|
|
set encoded [string trim [exec ./data/trapdoor $password]]
|
|
}
|
|
|
|
if {![cequal $correct $encoded]} {
|
|
puts "<TITLE>Bzzzzt!</TITLE>"
|
|
puts "<H1>Invalid password.</h1>"
|
|
puts "Please click the <b>Back</b> button and try again."
|
|
Log "Invalid admin password entered."
|
|
exit
|
|
}
|
|
}
|
|
|
|
proc CheckPassword {password} {
|
|
set encoded [string trim [exec ./data/trapdoor $password]]
|
|
set f [DataDir]/treepasswd
|
|
set correct "xxx $encoded"
|
|
if {[file exists $f]} {
|
|
set fid [open $f "r"]
|
|
set correct [string trim [read $fid]]
|
|
close $fid
|
|
}
|
|
|
|
if {![cequal $correct $encoded]} {
|
|
CheckGlobalPassword $password $encoded
|
|
}
|
|
}
|
|
|
|
|
|
proc ParseTimeAndCheck {timestr} {
|
|
if {[catch {set result [convertclock $timestr]}]} {
|
|
puts "
|
|
<TITLE>Time trap</TITLE>
|
|
<H1>Can't grok the time</H1>
|
|
You entered a time of <tt>$timestr</tt>, and I can't understand it. Please
|
|
hit <B>Back</B> and try again."
|
|
exit
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
|
|
proc MungeTagName {name} {
|
|
set result ""
|
|
foreach c [split $name ""] {
|
|
scan $c "%c" value
|
|
if {$value <= 32 || [regexp {[ %/?*]} $c]} {
|
|
append result [format "%%%02x" $value]
|
|
} else {
|
|
append result $c
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
# Given a person's username, get back their full email address.
|
|
# ### This needs to be paramaterized...
|
|
proc EmailFromUsername {name} {
|
|
regsub {%} $name {@} name
|
|
if {[string first "@" $name] < 0} {
|
|
append name "@netscape.com"
|
|
}
|
|
return $name
|
|
}
|