gecko-dev/webtools/bonsai/globals.tcl

728 строки
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 lxr_base http://cvs-mirror.mozilla.org/webtools/lxr/source
set mozilla_lxr_kludge TRUE
set ldapserver nsdirectory.mcom.com
# set ldapserver hoth.mcom.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
if {![info exists mysqlhandle]} {
set mysqlhandle [mysqlconnect]
mysqluse $mysqlhandle "bonsai"
}
}
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
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" {\&amp;} var
regsub -all {<} "$var" {\&lt;} var
regsub -all {>} "$var" {\&gt;} 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
"
exec /usr/lib/sendmail -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
}