'
config /config 41
1394330578 'timeline-plaintext' value '1'
config /config 11144
1472992109 'th1-setup' value '
#-- Pre-increment [++ varname]
proc ++ {varname} {
upvar 1 $varname i
return [uplevel 1 "set {$varname} [expr 1+$i]"]
}
#-- ternary / if-shorthand (cond/then/else may be literals, or {[expressions]} themselves)
proc ?: {cond then else} {
uplevel 1 "if {$cond} { return $then; } else { return $else; }"
}
#-- info exists shorthand
proc isset {varname} {
return [uplevel 1 "info exists {$varname}"]
}
#-- string equality shorthand
proc eq {str1 str2} {
return [expr {$str1 eq $str2}]
}
#-- while loop
proc while {condition code} {
return [uplevel 1 "for {} {$condition} {} {$code}"]
}
#-- foreach VAR "abc xyz 123" { puts "($VAR) " }
proc foreach {varname list code} {
upvar 1 $varname val
for {set i 0} {$i < [llength $list]} {++ i} {
set val [lindex $list $i]
uplevel 1 "$code"
}
}
#-- A switch statement.
#
# switch "val" {
# "cmp1" {code1}
# "cmp2" {code2}
# "cmp3" {code3}
# {{default}} {codeN}
# }
#
proc switch {compare_value val_code_pairs} {
set len [llength $val_code_pairs]
# loop over compare values + code pairs
for {set n 0} {$n < $len} {++ n} {
set cmp [lindex $val_code_pairs $n];
if {[expr $cmp eq $compare_value || $cmp eq {{default}} ]} {
return [uplevel 1 [lindex $val_code_pairs [++ n]]];
}
}
}
#-- Ordered list of project statistics (will populate global $stats() array)
proc ui::stats {} {
uplevel 1 { query {SELECT
(SELECT count(objid) FROM event WHERE type=''ci'' LIMIT 1) AS `stats_checkins`,
(SELECT count(name) FROM filename LIMIT 1) AS `stats_files`,
(SELECT count(status) FROM ticket LIMIT 1) AS `stats_tickets`,
(SELECT count(DISTINCT user) FROM event LIMIT 1) AS `stats_developers`,
(SELECT count(DISTINCT value) FROM tagxref WHERE tagid=8) AS `stats_branches`,
(SELECT count(tagname) FROM tag WHERE tagname LIKE ''sym-%'') AS `stats_tags`,
(SELECT count(tagname) FROM tag WHERE tagname REGEXP ''^sym[-a-z0-9_.]+\d+\.\d+'') AS `stats_releases`
} {} }
}
#-- Language/Content statistics (outputs colored bar graph)
proc ui::lang_stats {} {
# fetch $lang(js/...), $lang_color(js), $lang_list, $total_size
query {SELECT name, value FROM fx_stats ORDER by VALUE DESC} {
set $name $value
}
# output color bar for language proportions
#html "
"
foreach name $lang_list {
set percent "[expr $lang($name)*100]%"
html "";
}
#html "
";
}
#-- print two table rows for last commit
proc ui::last_commit {} {
query {
SELECT *, CAST(julianday(''now'')-mtime AS INT) AS age, substr(comment,0,199) AS msg, substr(uuid, 0, 10) AS short_uuid
FROM event JOIN blob ON blob.rid=event.objid
WHERE type=''ci'' ORDER BY mtime DESC LIMIT 1
} {
html "
";
}
}
#-- outputs table rows containing top-level filenames and recent checkin comments
proc ui::recent_files {dirname} {
set seen "(.gitignore)"
# search files using directory as base path
set branch "trunk"
set cutname 0
set AND_DIR ""
if {[string length $dirname]} {
set dirname "$dirname/"
set cutname [string length $dirname]
set AND_DIR " AND substr(name, 0, \$cutname+1) = \$dirname "
}
# files // vcache.rid=mlink.fid would be easier to skip deleted files, but access is prohibited(?)
query "
SELECT DISTINCT
m.fnid,
INSTR(SUBSTR(name,\$cutname+1),''/'')>0 AS is_dir,
name AS pathname,
bf.rid AS fn_rid, bf.uuid AS fn_uuid,
bm.rid AS ci_rid, bm.uuid AS ci_uuid,
SUBSTR(comment, 0, 70) AS comment,
CAST(JULIANDAY(''now'')-e.mtime AS INT) AS age
FROM
filename
LEFT JOIN mlink m ON m.fnid = filename.fnid
LEFT JOIN tagxref ON m.mid = tagxref.rid
LEFT JOIN blob bf ON bf.rid = m.fid
LEFT JOIN blob bm ON bm.rid = m.mid
LEFT JOIN event e ON e.objid = m.mid
WHERE
--tagxref.value = \$branch AND
m.fnid NOT IN (SELECT fnid FROM mlink m LEFT JOIN tagxref x ON m.mid=x.rid WHERE fid=0 AND x.value=\$branch)
$AND_DIR
GROUP BY
name
ORDER BY
is_dir DESC, name ASC, e.mtime DESC
" {
# separate directories and files
set name [string range $pathname $cutname 2048]
set dir [string first "/" $name]
if {$dir>0} { set name [string range $name 0 [expr $dir-1]] }
# skip seen files
if [str::contains "($name)" $seen] { continue } else { set seen "($name),$seen" }
# output table entries
html "
";
if {$dir>0} {
# if there is an equivalent wiki page for a directory, then we mix filebox + wiki
set display "wiki"
#set display [?: [sql::page_exists "$dirname$name"] "wiki" "tree"]
html "๐ [htmlize $name]";
} else {
html "๐ [htmlize $name]";
}
html "
\n";
}
}
#-- social media share links
proc ui::social_links {baseurl} {
html "
g+ ·
fb ·
tw ·
rd ·
in ·
su ·
dl
";
}
# Outputs a textual /changelog
proc webpage_changelog {} {
html "
\n\n";
set version "trunk"
puts "$version (unreleased)\n";
query {
SELECT event.mtime, tag.tagname, MAX(tag.tagid), DATE(event.mtime) AS d,
REPLACE(TRIM(REPLACE(event.comment, char(10,10), char(10)), char(8,10,13,32)), char(10), char(10,32,32,32)) AS comment
FROM event
LEFT JOIN tagxref ON event.objid=tagxref.rid
LEFT JOIN tag ON tagxref.tagid=tag.tagid
WHERE type=''ci''
GROUP BY objid
ORDER BY event.mtime DESC
LIMIT 750
} {
if {[regexp {^sym-.*\d+\.\d+} $tagname]} {
for {} {[string length $tagname] >= 3 && [regexp {^\d+\.} $tagname] == 0} {} {
set tagname [string range $tagname 1 100]
}
puts "\n$tagname ($d)\n";
}
puts " * $comment\n";
}
puts "\n\n";
}
# Alternative to /raw trunk file access without ?name=uuid,
# Doesn''t work with CONTENT() yet.
proc webpage_cat {} {
set name [getParameter name ""]
if {![string length $name]} { puts "No filename given."; break; }
query {
SELECT uuid
FROM blob LEFT JOIN mlink ON blob.rid=mlink.fid
LEFT JOIN filename ON mlink.fnid=filename.fnid
WHERE name = $name
ORDER BY rid DESC LIMIT 1
} { html [artifact "$uuid"]; }
}
# Generate a text/uri-list for available files
proc webpage_uri-list {} {
query {
SELECT filename.name, uuid
FROM blob LEFT JOIN mlink ON blob.rid=mlink.fid LEFT JOIN filename ON mlink.fnid=filename.fnid
GROUP BY filename.name ORDER BY rid DESC
} { puts "$name?name=$uuid\n" }
}
# Invokes web request page procs
proc webpage_hook {} {
#if {! [anycap ro]} { break }
catch { "webpage_$::web_name"; return -code 2 found; } rc
if {"$rc" eq "found"} { break continue }
}
#-- Whitelist for SQL params
# Just realized this is redundant; because query {} accepts
# uninterpolated \$varnames as parameter placeholders.
proc sql::allowed {str} {
return [regexp {^[-a-zA-Z0-9 !$&/(){}=<>,.;:_+#*@]+$} $str]
}
#-- Also prohibit regex special chars
proc sql::allowed_regexp {str} {
return [regexp {^[-a-zA-Z0-9 !$&/ =<>,.;:_ # @]+$} $str]
}
#-- Check for existence of wiki page
proc sql::page_exists {name} {
query {SELECT 1 FROM tag WHERE tagname = (''wiki-'' || $name)} { return 1 }
return 0
}
#-- Check if exact file name (including path) exists in repository
proc sql::file_exists {name} {
query {SELECT 1 FROM filename WHERE name = $name} { return 1 }
return 0
}
#-- Find file by basename
proc sql::find_file {path} {
if {![sql::allowed_regexp $path]} { return 0 }
query {SELECT name FROM filename WHERE name REGEXP (''(^|/)'' || $path || ''\$'')} { return $name }
return ""
}
#-- Check if directory exists
proc sql::dir_exists {path} {
if {![sql::allowed_regexp $path]} { return 0 }
query {SELECT name FROM filename WHERE name REGEXP (''^'' || $path || ''/.+'')} { return 1 }
return 0
}
#-- returns true if string contained in another string
proc str::contains {needle haystack} {
return [expr {-1 != [string first $needle $haystack]}]
}
#-- wrapper for [string first ...] to support startindex
proc str::next {search content start} {
# cut out $content at $start before searching
set p [string first $search [string range $content $start [string length $content]]]
if [expr $p>=0] {
set p [expr $start+$p]
}
return $p
}
#-- enclose string in e.g. html tags
proc str::wrap {content search before after} {
set len [string length $search]
set p 0
while {[expr [set p [str::next $search $content $p]]>=0]} {
set content "[string range $content 0 [expr $p-1]]$before$search$after[string range $content [expr $p+$len] 2000]";
set p [expr $p+[string length "$before+$search+$after"]]; # skip a little further
}
return $content
}
#-- Split string into list on delimiter character
# (basically just turns delimiter into space)
#
proc str::explode {delim str} {
set r ""
set len [string length $str]
while {-1 != [set p [string first $delim $str]]} {
set r "$r [string range $str 0 [expr $p-1]]"
set str [string range $str [++ p] $len]
}
return [list [string trim "$r $str"]]
}
#-- Extract dirname from path/file/name
proc str::dirname {path} {
return [string range $path 0 [expr [string last "/" $path]-1]]
}
'