Check-in [82270c3d74]
Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Split up th1x into individual sections (basic control structures, str, sql functions, and github-specific ui:: functions). Rename changelog to hooks. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
82270c3d74ee4231d4fce9edd3c0780d |
User & Date: | mario 2015-02-09 01:52:44 |
Context
2015-02-09
| ||
21:41 | Switch from CONTENT() to TH1 [artifact $uuid] for cat/ webhook. Fix catch and continue/break handling, to avoid "Not Found" errors for existing hook page procs. check-in: 5df8180404 user: mario tags: trunk | |
01:52 | Split up th1x into individual sections (basic control structures, str, sql functions, and github-specific ui:: functions). Rename changelog to hooks. check-in: 82270c3d74 user: mario tags: trunk | |
00:44 | TH1-hooks for /changelog, /cat (doesn't work), and /uri-list. check-in: f87b2e4f1d user: mario tags: trunk | |
Changes
Added features/basic.th1.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | #-- 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]]]; } } } |
Added features/github.th1.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | #-- 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 "<div class=language-bar style='width:100%; height:3pt; box-sizing:border-box;'>" foreach name $lang_list { set percent "[expr $lang($name)*100]%" html "<span class=code-rate-$name style='height:100%; width:$percent; display:inline-block; background-color:#$lang_color($name)' title='$percent $name'></span>"; } #html "</div>"; } #-- 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 " <tr><th colspan=3>$msg</th></tr>"; html " <tr><th colspan=3 style=background:#fff><a href='timeline?u=$user' class=user>$user</a> authored $age days ago <span style=float:right>last checkin <a href='ci/$uuid'>$short_uuid <span class=glyph>⎘</span></a></span></th></tr>"; } } #-- 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 mlink.fnid, instr(substr(name,\$cutname+1),'/') 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')-event.mtime AS INT) AS age FROM filename JOIN mlink ON mlink.fnid=filename.fnid JOIN blob bf ON bf.rid=mlink.fid JOIN blob bm ON bm.rid=mlink.mid JOIN event ON event.objid=mlink.mid WHERE mlink.fnid NOT IN (SELECT fnid FROM mlink LEFT JOIN tagxref ON mlink.mid=tagxref.rid WHERE fid=0 AND tagxref.value=\$branch) $AND_DIR GROUP BY name ORDER BY is_dir DESC, name ASC, event.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 " <tr><td>"; 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 "<a class=dir href='$display?name=[htmlize $dirname$name]'><b class=glyph>๐</b> [htmlize $name]</a>"; } else { html "<a class=file href='artifact/$fn_uuid'><b class=glyph>๐</b> [htmlize $name]</a>"; } html "</td> <td>[htmlize $comment]<a href='ci/$ci_uuid'>โนโบ</a></td> <td>[htmlize $age] days ago</td></tr>\n"; } } #-- social media share links proc ui::social_links {baseurl} { html " <a class=sml-go href='https://plus.google.com/share?url=$baseurl' title=google+>g+</a> · <a class=sml-fb href='https://www.facebook.com/sharer/sharer.php?u=$baseurl' title=facebook>fb</a> · <a class=sml-tw href='https://twitter.com/intent/tweet?url=$baseurl' title=twitter>tw</a> · <a class=sml-rd href='http://reddit.com/submit?url=$baseurl' title=reddit>rd</a> · <a class=sml-in href='https://www.linkedin.com/shareArticle?mini=true&url=$baseurl' title=linkedin>in</a> · <a class=sml-su href='https://www.stumbleupon.com/submit?url=$baseurl' title=stumbleupon>su</a> · <a class=sml-dl href='https://del.icio.us/post?url=$baseurl' title=delicious>dl</a> "; } |
Name change from features/th1-changelog.tcl to features/hooks.th1.
︙ | ︙ | |||
53 54 55 56 57 58 59 | } # Invokes web request page procs proc webpage_hook {} { #if {! [anycap ro]} { break } catch { "webpage_$::web_name"; return TH_CONTINUE; } } | > | 53 54 55 56 57 58 59 60 | } # Invokes web request page procs proc webpage_hook {} { #if {! [anycap ro]} { break } catch { "webpage_$::web_name"; return TH_CONTINUE; } } |
Added features/sql.th1.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | #-- 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 } |
Added features/str.th1.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | #-- 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]] } |
Deleted features/th1x.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |