# -*- tcl -*-
# # ## ### ##### ######## ############# ######################
# @@ Meta Begin
# Package m::glue 0
# Meta author {Andreas Kupries}
# Meta category ?
# Meta description ?
# Meta location https://core.tcl-lang.org/akupries/m
# Meta platform tcl
# Meta require ?
# Meta subject ?
# Meta summary ?
# @@ Meta End
# # ## ### ##### ######## ############# ######################
package provide m::glue 0
package require Tcl 8.5
package require cmdr::color
package require cmdr::table 0.1 ;# API: headers, borders
package require debug
package require debug::caller
package require m::msg
package require m::format
# # ## ### ##### ######## ############# ######################
namespace eval ::m {
namespace export glue
namespace ensemble create
}
namespace eval ::m::glue {
namespace export cmd_* gen_*
namespace ensemble create
namespace import ::cmdr::color
namespace import ::cmdr::table::general ; rename general table
namespace import ::cmdr::table::dict ; rename dict table/d
}
# # ## ### ##### ######## ############# ######################
debug level m/glue
debug prefix m/glue {}
#debug prefix m/glue {[debug caller] | }
# # ## ### ##### ######## ############# ######################
proc ::m::glue::gen_report_destination {p} {
debug.m/glue {[debug caller] | }
package require m::state
set email [m state report-mail-destination]
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $email }
return $email
}
proc ::m::glue::gen_limit {p} {
debug.m/glue {[debug caller] | }
package require m::state
set limit [m state limit]
if {$limit == 0} {
set limit [expr {[$p config @th]-7}]
}
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $limit }
return $limit
}
proc ::m::glue::gen_submit_url {p} {
debug.m/glue {[debug caller] | }
package require m::submission
set details [m submission get [$p config @id]]
dict with details {}
# -> url
# email
# submitter
# when
# desc
# vcode
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $url }
return $url
}
proc ::m::glue::gen_submit_name {p} {
debug.m/glue {[debug caller] | }
package require m::submission
set details [m submission get [$p config @id]]
dict with details {}
# -> url
# email
# submitter
# when
# desc
# vcode
if {$desc eq {}} {
set desc [gen_name $p]
}
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $desc }
return $desc
}
proc ::m::glue::gen_submit_vcs {p} {
debug.m/glue {[debug caller] | }
package require m::submission
package require m::vcs
set details [m submission get [$p config @id]]
dict with details {}
# -> url
# email
# submitter
# when
# desc
# vcode
if {$vcode eq {}} {
set vcs [gen_vcs $p]
} else {
set vcs [m vcs id $vcode]
}
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $vcode ($vcs) }
return $vcs
}
proc ::m::glue::gen_name {p} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::vcs
# Derive a name from the url when no such was specified by the
# user. Add a serial number if that name is already in use.
set name [MakeName \
[m vcs name-from-url \
[$p config @vcs-code] \
[$p config @url]]]
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $name }
return $name
}
proc ::m::glue::gen_vcs {p} {
debug.m/glue {[debug caller] | }
# Auto detect vcs of url when not specified by the user.
package require m::validate::vcs
package require m::vcs
#
set vcs [m validate vcs validate $p [m vcs detect [$p config @url]]]
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $vcs }
return $vcs
}
proc ::m::glue::gen_vcs_code {p} {
debug.m/glue {[debug caller] | }
# Determine vcs code from the database id.
package require m::vcs
#
set vcode [m vcs code [$p config @vcs]]
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | --> $vcode }
return $vcode
}
proc ::m::glue::gen_current {p} {
debug.m/glue {[debug caller] | }
# Provide current as repository for operation when not specified
# by the user. Fail if we have no current repository.
package require m::rolodex
#
set r [m rolodex top]
if {$r ne {}} {
debug.m/glue {[debug caller] | --> $r }
return $r
}
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | undefined }
$p undefined!
# Will not reach here
}
proc ::m::glue::gen_current_project {p} {
debug.m/glue {[debug caller] | }
# Provide current as project for operation when not specified
# by the user. Fail if we have no current repository to trace
# from.
package require m::repo
package require m::rolodex
#
set r [m rolodex top]
if {$r ne {}} {
set project [m repo project $r]
if {$project ne {}} {
debug.m/glue {[debug caller] | --> $project }
return $project
}
}
debug.m/glue {[debug caller] | [$p config] }
debug.m/glue {[debug caller] | undefined }
$p undefined!
# Will not reach here
}
# # ## ### ##### ######## ############# ######################
proc ::m::glue::cmd_import {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
package require m::url
set dated [$config @dated]
if {[$config @spec set?]} {
set sname [$config @spec string]
} else {
set sname {standard input}
}
m msg "Processing ..."
ImportDo $dated \
[ImportSkipKnown \
[ImportVerify \
[ImportRead $sname [$config @spec]]]]
SiteRegen
OK
}
proc ::m::glue::cmd_export {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
m msg [m project spec]
}
proc ::m::glue::cmd_reply_add {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::reply
m db transaction {
set reply [$config @reply]
set text [$config @text]
set mail [$config @auto-mail]
m msg "New reason to reject a submission:"
m msg " Name: [color note $reply]"
m msg " Text: [color note $text]"
m msg " AutoMail: [expr {$mail ? "yes" : "no"}]"
m reply add $reply $mail $text
}
#SiteRegen
OK
}
proc ::m::glue::cmd_reply_remove {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::reply
m db transaction {
set reply [$config @reply]
set name [$config @reply string]
m msg "Remove [color note $name] as reason for rejecting a submission."
if {[m reply default? $reply]} {
m::cmdr::error \
"Cannot remove default reason" \
UNREMOVABLE DEFAULT
}
m reply remove $reply
}
#SiteRegen
OK
}
proc ::m::glue::cmd_reply_change {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::reply
m db transaction {
set reply [$config @reply]
set name [$config @reply string]
set text [$config @text]
m msg "Change reason [color note $name] to reject a submission:"
m msg " New text: [color note $text]"
m reply change $reply $text
}
#SiteRegen
OK
}
proc ::m::glue::cmd_reply_default {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::reply
m db transaction {
set reply [$config @reply]
set name [$config @reply string]
m msg "Set [color note $name] as default reason to reject a submission."
m reply default! $reply
}
#SiteRegen
OK
}
proc ::m::glue::cmd_reply_show {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::reply
m db transaction {
ReplyConfigShow
}
OK
}
proc ::m::glue::cmd_mailconfig_show {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
[table/d t {
MailConfigShow $t
}] show
}
OK
}
proc ::m::glue::cmd_siteconfig_show {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
[table/d t {
SiteConfigShow $t
}] show
}
OK
}
proc ::m::glue::cmd_show {config} {
debug.m/glue {[debug caller] | }
package require m::repo
package require m::state
set all [$config @all]
m db transaction {
set n [m state limit]
if {!$n} { set n [color note {adjust to terminal height}] }
[table/d t {
$t add Store [m state store]
$t add Limit $n
$t add Take "[m state take] ([m repo count-pending] pending/[m repo count] total)"
$t add Window [m state store-window-size]
$t add {Report To} [m state report-mail-destination]
$t add {-} {}
$t add {Cycle, Last} [m format epoch [m state start-of-previous-cycle]]
$t add {Cycle, Now} [m format epoch [m state start-of-current-cycle]]
if {$all} {
package require m::db
package require m::reply
$t add Site {}
SiteConfigShow $t {- }
$t add Mail {}
MailConfigShow $t {- }
}
}] show
}
OK
}
proc ::m::glue::cmd_mailconfig {key desc config} {
debug.m/glue {[debug caller] | }
package require m::state
set prefix Current
m db transaction {
set value [m state $key]
if {[$config @value set?]} {
set new [$config @value]
if {$new ne $value} {
m state $key $new
set prefix New
set value $new
}
}
}
m msg "$prefix $desc: [color note $value]"
OK
}
proc ::m::glue::cmd_siteconfig {key desc config} {
debug.m/glue {[debug caller] | }
package require m::state
set prefix Current
m db transaction {
set value [m state $key]
if {[$config @value set?]} {
set new [$config @value]
if {$new ne $value} {
m state $key $new
set prefix New
set value $new
}
}
m msg "$prefix $desc: [color note $value]"
if {($prefix eq "New") && ($value eq "")} {
SiteEnable 0
}
}
if {$prefix eq "New"} SiteRegen
OK
}
proc ::m::glue::cmd_site_off {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
SiteEnable 0
}
OK
}
proc ::m::glue::cmd_site_on {config} {
debug.m/glue {[debug caller] | }
package require m::state
package require m::web::site
set mode [expr {[$config @silent] ? "silent" : ""}]
m db transaction {
SiteEnable 1
[table/d t {
SiteConfigShow $t
}] show
#
m web site build $mode
}
OK
}
proc ::m::glue::cmd_site_sync {config} {
debug.m/glue {[debug caller] | }
package require m::web::site
m db transaction {
m web site sync
}
OK
}
proc ::m::glue::cmd_store {config} {
debug.m/glue {[debug caller] | }
package require m::store
set prefix Current
m db transaction {
set value [m state store]
if {[$config @path set?]} {
set new [file normalize [$config @path]]
if {$new ne $value} {
m store move-location $new
set prefix New
set value $new
}
}
}
m msg "$prefix Store at [color note $value]"
if {$prefix eq "New"} SiteRegen
OK
}
proc ::m::glue::cmd_report2 {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
if {[$config @mail set?]} {
m state report-mail-destination [$config @mail]
}
set mail [m state report-mail-destination]
}
m msg "Send report mails to [color note $mail]"
OK
}
proc ::m::glue::cmd_take {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
if {[$config @take set?]} {
m state take [$config @take]
}
set n [m state take]
}
set g [expr {$n == 1 ? "project" : "projects"}]
m msg "Per update, take [color note $n] $g"
OK
}
proc ::m::glue::cmd_window {config} {
debug.m/glue {[debug caller] | }
package require m::state
m db transaction {
if {[$config @window set?]} {
m state store-window-size [$config @window]
}
set n [m state store-window-size]
}
set g [expr {$n == 1 ? "time" : "times"}]
m msg "Keep [color note $n] update $g per repository for the moving average"
OK
}
proc ::m::glue::cmd_vcs {config} {
debug.m/glue {[debug caller] | }
package require m::vcs
m db transaction {
set all [m vcs all]
}
foreach {code name} $all {
set version [m vcs version $code issues]
set vmsg {}
if {$version ne {}} {
lappend vmsg [color note $version]
}
if {[llength $issues]} {
foreach issue $issues {
lappend vmsg [color bad $issue]
}
}
lappend series $code $name [join $vmsg \n]
}
m msg [color note {Supported VCS}]
[table t {Code Name Version} {
foreach {code name msg} $series {
$t add $code $name $msg
}
}] show
OK
}
proc ::m::glue::cmd_add {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
m db transaction {
Add $config
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::cmd_remove {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
m db transaction {
set repo [$config @repository]
set rinfo [m repo get $repo]
dict with rinfo {}
# -> url : repo url
# vcs : vcs id
# -> vcode : vcs code
# -> project: project id
# -> name : project name
# -> store : id of backing store for repo
m msg "Removing $vcode repository [color note $url] ..."
m msg "from Project [color note $name]"
m repo remove $repo
set siblings [m store remotes $store]
set nsiblings [llength $siblings]
if {!$nsiblings} {
m msg "- Removing unshared $vcode store $store ..."
m store remove $store
} else {
set x [expr {($nsiblings == 1) ? "repository" : "repositories"}]
m msg "- Keeping $vcode store $store still used by $nsiblings $x"
}
# Remove project if no repositories remain at all.
set nsiblings [m project size $project]
if {!$nsiblings} {
m msg "- Removing now empty project ..."
m project remove $project
} else {
set x [expr {($nsiblings == 1) ? "repository" : "repositories"}]
m msg "- Keeping project still used by $nsiblings $x"
}
m rolodex drop $repo
m rolodex commit
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::L {text} {
upvar 1 w w
set r {}
foreach line [split $text \n] {
if {[string length $line] > $w} {
set line [string range $line 0 ${w}-5]...
}
lappend r $line
}
join $r \n
}
proc m::glue::Short {repo} {
set ri [m repo get $repo]
dict with ri {}
set active [color {*}[dict get {
0 {warning offline}
1 {note UP}
} [expr {!!$active}]]]
return "$url ([SIB [expr {!$issues}]] $active)"
}
proc ::m::glue::cmd_details {config} { ;# XXX REWORK due the project/repo/store relation changes
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::state
package require m::store
package require linenoise
set w [$config @tw] ;#linenoise columns
# table/d -> 2 columns, 7 overhead, 1st col 14 wide =>
set w [expr {$w - 21}] ;# max width for col 2.
m db transaction {
set full [$config @full]
set repo [$config @repository]
# Basic repository details ...........................
set rinfo [m repo get $repo]
dict with rinfo {}
#m msg "Details of [color note $url] ..."
# -> url : repo url
# active : usage state
# vcs : vcs id
# vcode : vcs code
# * project: project id
# * name : project name
# -> store : id of backing store for repo
# min_sec: minimal time spent on setup/update
# max_sec: maximal time spent on setup/update
# win_sec: last n times for setup/update
# checked: epoch of last check
# origin : repository this is forked from, or empty
set spent [StatsTime $min_sec $max_sec $win_sec]
# Get store details ...
set path [m store path $store]
set sd [m store get $store]
dict unset sd vcs
dict unset sd min_sec
dict unset sd max_sec
dict unset sd win_sec
dict with sd {}
# size, sizep
# commits, commitp
# vcsname
# created
# changed
# updated
lassign [m vcs caps $store] stdout stderr
set stdout [string trim $stdout]
set stderr [string trim $stderr]
# Find repositories sharing the store ................
set storesibs [m store repos $store]
# Find repositories which are siblings of the same origin
set forksibs {}
set dorigin {}
if {$origin ne {}} {
set forksibs [m repo forks $origin]
set dorigin [Short $origin]
}
# Find repositories which are siblings of the same project
set projectsibs [m repo for $project]
#puts O(($origin))/\nR(($repo))/\nS(($storesibs))/\nF(($forksibs))/\nP(($projectsibs))
# Compute derived information ...
set status [SI $stderr]
set export [m vcs export $vcs $store]
set dcommit [DeltaCommitFull $commits $commitp]
set dsize [DeltaSizeFull $size $sizep]
set changed [color note [m format epoch $changed]]
set updated [m format epoch $updated]
set created [m format epoch $created]
set active [color {*}[dict get {
0 {warning offline}
1 {note UP}
} [expr {!!$active}]]]
set s [[table/d s {
$s borders 0
set sibs 0
foreach sibling $storesibs {
if {$sibling == $repo} continue
incr sibs
$s add ${sibs}. [Short $sibling]
}
if {$sibs} { $s add {} {} }
$s add Size $dsize
$s add Commits $dcommit
if {$export ne {}} {
$s add Export $export
}
$s add {Update Stats} $spent
$s add {Last Change} $changed
$s add {Last Check} $updated
$s add Created $created
if {!$full} {
set nelines [llength [split $stderr \n]]
set nllines [llength [split $stdout \n]]
if {$nelines == 0} { set nelines [color note {no log}] }
if {$nllines == 0} { set nllines [color note {no log}] }
$s add Operation $nllines
if {$stderr ne {}} {
$s add "Notes & Errors" [color bad $nelines]
} else {
$s add "Notes & Errors" $nelines
}
} else {
if {$stdout ne {}} { $s add Operation [L $stdout] }
if {$stderr ne {}} { $s add "Notes & Errors" [L $stderr] }
}
}] show return]
[table/d t {
$t add {} [color note $url]
if {$origin ne {}} {
$t add Origin $dorigin
}
$t add Status "$status $active @[color note [m format epoch $checked]]"
$t add Project $name
$t add VCS $vcsname
$t add {Local Store} $path
$t add {} $s
# Show other locations serving the project, except for forks.
# Forks are shown separately.
set sibs 0
foreach sibling $projectsibs {
if {$sibling == $repo} continue
if {$sibling == $origin} continue
if {$sibling in $storesibs} continue
if {$sibling in $forksibs} continue
if {!$sibs} { $t add Other {} }
incr sibs
$t add ${sibs}. [Short $sibling]
}
set threshold 20
# Show the sibling forks. Only the first, only if not sharing the store.
set sibs 0
foreach sibling $forksibs {
if {$sibling == $repo} continue
if {$sibling == $origin} continue
if {$sibling in $storesibs} continue
if {!$sibs} { $t add Related {} }
incr sibs
#
if {$sibs > $threshold} continue
$t add ${sibs}. [Short $sibling]
}
if {$sibs > $threshold} {
$t add {} "(+[expr {$sibs - $threshold}] more)"
}
}] show
}
OK
}
proc ::m::glue::SI {stderr} {
SIB [expr {$stderr eq {}}]
}
proc ::m::glue::SIB {ok} {
color {*}[dict get {
0 {bad ATTEND}
1 {good OK}
} $ok]
}
proc ::m::glue::cmd_enable {flag config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
set op [expr {$flag ? "Enabling" : "Disabling"}]
m db transaction {
foreach repo [$config @repositories] {
m msg "$op [color note [m repo name $repo]] ..."
set rinfo [m repo get $repo]
dict with rinfo {}
# -> url : repo url
# vcs : vcs id
# vcode : vcs code
# project: project id
# name : project name
# store : id of backing store for repo
m repo enable $repo $flag
# Note: We do not manipulate `repo_pending`. An existing
# repo is always in `repo_pending`, even if it is
# inactive. The commands to retrieve the pending repos
# (all, or taken for update) is where we do the filtering,
# i.e. exclusion of the inactive.
}
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::cmd_rename {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::store
m db transaction {
set project [$config @project] ; debug.m/glue {project : $project}
set newname [$config @name] ; debug.m/glue {new name: $newname}
set oldname [m project name $project]
m msg "Renaming [color note $oldname] ..."
if {$newname eq $oldname} {
m::cmdr::error \
"The new name is the same as the current name." \
NOP
}
if {[m project has $newname]} {
m::cmdr::error \
"New name [color note $newname] already present" \
HAVE_ALREADY NAME
}
Rename $project $newname
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::cmd_merge {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
package require m::vcs
m db transaction {
set msets [Dedup [MergeFill [$config @projects]]]
# __Attention__: Cannot place the mergefill into a generate
# clause, the parameter logic is too simple (set / not set) to
# handle the case of `set only one`.
debug.m/glue {msets = ($msets)}
if {[llength $msets] < 2} {
m::cmdr::error \
"All repositories are already in the same project." \
NOP
}
set secondaries [lassign $msets primary]
m msg "Target: [color note [m project name $primary]]"
foreach secondary $secondaries {
m msg "Merging: [color note [m project name $secondary]]"
Merge $primary $secondary
}
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::cmd_split {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
package require m::vcs
m db transaction {
set repo [$config @repository]
set rinfo [m repo get $repo]
dict with rinfo {}
# -> url : repo url
# vcs : vcs id
# vcode : vcs code
# project: project id
# name : project name
# store : id of backing store for repo
m msg "Attempting to separate"
m msg " Repository [color note $url]"
m msg " Managed by [color note [m vcs name $vcs]]"
m msg "From"
m msg " Project [color note $name]"
if {[m project size $mset] < 2} {
m::cmdr::error \
"The project is to small for splitting" \
ATOMIC
}
set newname [MakeName $name]
set projectnew [m project add $newname]
m msg "New"
m msg " Project [color note $newname]"
m repo move/1 $repo $projectnew
if {![m project has-vcs $mset $vcs]} {
# The moved repository was the last user of its vcs in the
# original project. We can simply move its store over
# to the new holder to be ok.
m msg " Move store ..."
m store move $store $projectnew
} else {
# The originating mset still has users for the store used
# by the moved repo. Need a new store for the moved repo.
m msg " Split store ..."
m store cleave $store $projectnew
}
}
ShowCurrent $config
SiteRegen
OK
}
proc ::m::glue::cmd_current {config} {
debug.m/glue {[debug caller] | }
ShowCurrent $config
OK
}
proc ::m::glue::cmd_swap_current {config} {
debug.m/glue {[debug caller] | }
package require m::repo
package require m::rolodex
m db transaction {
m rolodex swap
m rolodex commit
}
ShowCurrent $config
OK
}
proc ::m::glue::cmd_set_current {config} {
debug.m/glue {[debug caller] | }
package require m::repo
package require m::rolodex
m db transaction {
m rolodex push [$config @repository]
m rolodex commit
}
ShowCurrent $config
OK
}
proc ::m::glue::cmd_update {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::state
package require m::store
package require struct::set
set startcycle [m state start-of-current-cycle]
set nowcycle [clock seconds]
m db transaction {
set verbose [$config @verbose]
set repos [UpdateRepos $startcycle $nowcycle [$config @repositories]]
debug.m/glue {repositories = ($repos)}
foreach repo $repos {
set ri [m repo get $repo]
dict with ri {}
# url, active, issues, vcs, vcode, project, name, store
# min/max/win_sec, checked, origin
set si [m store get $store]
# size, vcs, sizep, commits, commitp, vcsname, updated, changed, created
# (atted, min/max/win, remote, active)
set before [dict get $si commits]
set durl [color note $url]
if {$origin eq {}} { set durl [color bg-cyan $durl] }
m msg "Updating repository $durl ..."
m msg "In project [color note $name]"
if {$verbose} {
m msg " [color note [string totitle $vcode]] store ... "
} else {
m msg* " [string totitle $vcode] store ... "
}
set primary [expr {$origin eq {}}]
# -- has_issues, is_active/enable -- fork handling
set now [clock seconds]
lassign [m store update $primary $url $store $nowcycle $now $before] \
ok duration commits size forks
set attend [expr {!$ok || [m store has-issues $store]}]
set suffix ", in [color note [m format interval $duration]]"
m repo times $repo $duration $now $attend
if {!$primary && $attend} { m repo enable $repo 0 }
if {!$ok} {
lassign [m vcs caps $store] _ e
m msg "[color bad Fail]$suffix"
m msg $e
continue
} elseif {$before != $commits} {
set delta [expr {$commits - $before}]
if {$delta < 0} {
set mark bad
} else {
set mark note
set delta +$delta
}
m msg "[color note Changed] $before $commits ([color $mark $delta])$suffix"
} elseif {$verbose} {
m msg "[color note "No changes"]$suffix"
} else {
m msg "No changes$suffix"
}
if {$primary} {
# check currently found forks against what is claimed by the system
set forks_prev [m repo fork-locations $repo]
lassign [struct::set intersect3 $forks_prev $forks] same removed added
# previous - current => removed from previous
# current - previous => added over previous
# Actions:
# - The removed forks are detached from the primary.
# We keep the repository. Activation state is unchanged
#
# - Unchanged forks are reactivated if they got disabled.
#
# - New forks are attempted to be added back
# This may actually reclaim a fork which was declaimed before.
#
# Note: Only these new forks have to be validated!
# Note: Tracking threshold is irrelevant here.
foreach r $removed {
m msg " [color warning {Detaching lost}] [color note $r]"
m repo declaim [m repo id $r]
}
foreach r $same {
# m msg " Unchanged [color note $r], activating"
m repo enable [m repo id $r]
}
AddForks $added $repo $vcs $vcode $name $project
}
}
}
SiteRegen
OK
}
proc ::m::glue::cmd_updates {config} {
debug.m/glue {[debug caller] | }
package require m::store
m db transaction {
# m store updates XXX rework actually repos
# TODO: get status (stderr), show - store id
set series {}
foreach row [TruncH [m store updates] [expr {[$config @th]-1}]] {
if {[lindex $row 0] eq "..."} {
lappend series [list ... {} {} {} {} {} {}]
continue
}
# store mname vcode changed updated created size active
# remote sizep commits commitp mins maxs lastn url origin
dict with row {}
if {$created eq "."} {
lappend series [list - - - - - - -]
continue
}
set changed [m format epoch $changed]
set updated [m format epoch $updated]
set created [m format epoch $created]
set dsize [DeltaSize $size $sizep]
set dcommit [DeltaCommit $commits $commitp]
set lastn [LastTime $lastn]
if {$origin eq {}} { set url [color bg-cyan $url] }
lappend series [list $url $vcode $dsize $dcommit $lastn $changed $updated $created]
}
}
lassign [TruncW \
{Project VCS Size Commits Time Changed Updated Created} \
{1 0 0 0 0 0 0 0} \
$series [$config @tw]] \
titles series
m msg "Cycles: [m format epoch [m state start-of-previous-cycle]] ... [m format epoch [m state start-of-current-cycle]] ..."
[table t $titles {
foreach row $series {
$t add {*}$row
}
}] show
OK
}
proc ::m::glue::cmd_pending {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::state
set tw [$config @tw]
set th [$config @th] ; incr th -1 ;# Additional line before the table (counts).
set nrepo [m repo count]
set npending [m repo count-pending]
m db transaction {
set series {}
set take [m state take]
foreach {pname url origin nforks} [m repo pending] {
if {$origin eq {}} { set url [color bg-cyan $url] }
set row {}
if {$take} {
lappend row *
incr take -1
} else {
lappend row {}
}
lappend row $url $nforks $pname
lappend series $row
}
}
lassign [TruncW \
{{} Repository Forks Project} \
{0 0 0 1} \
[TruncH $series $th] $tw] \
titles series
puts @[color note $npending]/$nrepo
[table t $titles {
foreach row $series {
$t add {*}$row
}
}] show
OK
}
proc ::m::glue::cmd_issues {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
m db transaction {
set series {}
foreach row [m store issues] { ;# XXX rework actually repo issues
dict with row {}
# store mname vcode changed updated created size active remote rid url
set size [m format size $size]
if {$origin eq {}} { set url [color bg-cyan $url] }
lappend series [list $rid $url $mname $vcode $size]
m rolodex push $rid
}
m rolodex commit
set n [llength $series]
set table {}
foreach row $series {
incr n -1
set row [lassign $row rid]
set dex [m rolodex id $rid]
set tag @$dex
if {$n == 1} { lappend tag @p }
if {$n == 0} { lappend tag @c }
lappend table [list $tag {*}$row]
}
}
lassign [TruncW \
{Tag Repository Project VCS Size} \
{0 0 1 0 0} \
$table [$config @tw]] \
titles series
[table t $titles {
foreach row $series {
$t add {*}[C $row 1 note] ;# 1 => url
}
}] show
OK
}
proc ::m::glue::cmd_disabled {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
m db transaction {
set series {}
foreach row [m store disabled] { # XXX REWORK actually repo state
dict with row {}
# store mname vcode changed updated created size active remote attend rid url origin
set size [m format size $size]
if {$origin eq {}} { set url [color bg-cyan $url] }
lappend series [list $rid $url $mname $vcode $size]
m rolodex push $rid
}
m rolodex commit
set n [llength $series]
set table {}
foreach row $series {
incr n -1
set row [lassign $row rid]
set dex [m rolodex id $rid]
set tag @$dex
if {$n == 1} { lappend tag @p }
if {$n == 0} { lappend tag @c }
lappend table [list $tag {*}$row]
}
}
lassign [TruncW \
{Tag Repository Project VCS Size} \
{0 0 1 0 0} \
$table [$config @tw]] \
titles series
[table t $titles {
foreach row $series {
$t add {*}[C $row 1 note] ;# 1 => url
}
}] show
OK
}
proc ::m::glue::cmd_list {config} {
debug.m/glue {[debug caller] | }
package require m::repo
package require m::rolodex
package require m::state
m db transaction {
if {[$config @pattern set?]} {
# Search, shows all results. Does not move the cursor.
set pattern [$config @pattern]
set series [m repo search $pattern]
} else {
# No search, show a chunk of the list as per options.
if {[$config @repository set?]} {
set repo [$config @repository]
set ri [m repo get $repo]
dict with ri {}
# -> url : repo url
# vcs : vcs id
# vcode : vcs code
# project: project id
# -> name : project name
# store : id of backing store for repo
set first [list $name $url]
debug.m/glue {from request: $first}
unset name url vcs vcode store ri project
} else {
set first [m state top]
debug.m/glue {from state: $first}
}
set limit [$config @limit]
if {$limit == 0} {
set limit [expr {[$p config @th]-7}]
}
lassign [m repo get-n $first $limit] next series
debug.m/glue {next ($next)}
m state top $next
}
# series = list (dict (primary name url rid vcode sizekb active sizep commits commitp mins maxs lastn))
debug.m/glue {series ($series)}
set n 0
foreach row $series {
m rolodex push [dict get $row id]
incr n
}
set idx -1
set table {}
foreach row $series {
dict with row {}
# primary name url id vcode sizekb active sizep commits commitp mins maxs lastn
incr idx
#set url [color note $url]
set ix [m rolodex id $id]
set tag {}
if {$ix ne {}} { lappend tag @$ix }
if {$idx == ($n-2)} { lappend tag @p }
if {$idx == ($n-1)} { lappend tag @c }
set a [expr {$active ? "A" : "-"}]
if {$primary} { set url [color bg-cyan $url] }
set dsize [DeltaSize $sizekb $sizep]
set dcommit [DeltaCommit $commits $commitp]
set lastn [LastTime $lastn]
lappend table [list $tag $a $url $name $vcode $dsize $dcommit $lastn]
# ................. 0 1 2 3 4 5 6 7
}
}
# See also ShowCurrent
# TODO: extend list with store times ?
lassign [TruncW \
{Tag {} Repository Project VCS Size Commits Time} \
{0 0 0 1 0 -1 -1 0} \
$table [$config @tw]] \
titles series
[table t $titles {
foreach row $series {
$t add {*}[C $row 2 note] ;# 2 => url
}
}] show
OK
}
proc ::m::glue::cmd_reset {config} {
debug.m/glue {[debug caller] | }
package require m::state
m state top {}
m msg "List paging reset to start from the top/bottom"
OK
}
proc ::m::glue::cmd_rewind {config} {
debug.m/glue {[debug caller] | }
puts [info level 0] ;# XXX TODO FILL-IN rewind
return
}
proc ::m::glue::cmd_limit {config} {
debug.m/glue {[debug caller] | }
package require m::rolodex
package require m::state
m db transaction {
if {[$config @limit set?]} {
set limit [$config @limit]
m state limit $limit
m rolodex truncate
}
set n [m state limit]
}
if {$n == 0} {
m msg "Per list/rewind, [color note {adjust to terminal height}]"
} else {
set e [expr {$n == 1 ? "entry" : "entries"}]
m msg "Per list/rewind, show up to [color note $n] $e"
}
OK
}
proc ::m::glue::cmd_submissions {config} {
debug.m/glue {[debug caller] | }
package require m::submission
m db transaction {
# Dynamic: Description, Submitter
set series {}
foreach {id when url vcode desc email submitter} [m submission all] {
set id %$id
set when [m format epoch $when]
lappend series [list $id $when $url $vcode $desc $email $submitter]
}
}
lassign [TruncW \
{{} When Url VCS Description Email Submitter} \
{0 0 0 0 3 0 1} \
$series [$config @tw]] \
titles series
[table t $titles {
foreach row $series {
$t add {*}[C $row 2 note] ;# 2 => url
}
}] show
OK
}
proc ::m::glue::cmd_rejected {config} {
debug.m/glue {[debug caller] | }
package require m::submission
m db transaction {
set series {}
foreach {url reason} [m submission rejected] {
lappend series [list $url $reason]
}
}
lassign [TruncW \
{Url Reason} \
{1 0} \
$series [$config @tw]] \
titles series
[table t $titles {
foreach row $series {
$t add {*}[C $row 0 note] ;# 0 => url
}
}] show
OK
}
proc ::m::glue::cmd_submit {config} {
debug.m/glue {[debug caller] | }
package require m::submission
package require m::repo
# session id for cli, daily rollover, keyed to host and user
set sid "cli.[expr {[clock second] % 86400}]/[info hostname]/$::tcl_platform(user)"
m db transaction {
set url [Url $config]
set email [$config @email]
set submitter [$config @submitter]
set vcode [$config @vcs-code]
set desc [$config @name]
set url [m vcs url-norm $vcode $url]
set name <[color note $email]>
if {$submitter ne {}} {
set name "[color note $submitter] $name"
}
m msg "Submitted: [color note $vcode] @ [color note $url]"
if {$desc ne {}} {
m msg "Description: [color note $desc]"
}
m msg "By: $name"
if {[m repo has $url]} {
m msg [color bad "Already known"]
return
}
if {[set reason [m submission dup $url]] ne {}} {
m msg [color bad "Already rejected: $reason"]
return
} elseif {[m submission has^ $url $sid]} {
m msg [color warning "Already submitted, replacing"]
} else {
m msg [color warning "Adding"]
}
m submission add $url $sid $vcode $desc $email $submitter
}
SiteRegen
OK
}
proc ::m::glue::cmd_accept {config} {
debug.m/glue {[debug caller] | }
package require m::project
package require m::repo
package require m::rolodex
package require m::store
package require m::submission
package require m::mail::generator
package require m::mailer
m db transaction {
set nomail [$config @nomail]
set submission [$config @id]
set details [m submission get $submission]
dict with details {}
# -> url
# email
# submitter
# when
# desc
# vcode
set name [color note $email]
if {$submitter ne {}} {
append name " ([color note $submitter])"
}
m msg "Accepted $url"
m msg "By $name"
Add $config
m submission accept $submission
# TODO: Ordering ... mail failure has to undo the store
# creation, and other non-database effects of `Add`.
if {!$nomail} {
m msg "Sending acceptance mail to $email ..."
dict set details when [m format epoch $when]
if {![info exists $submitter] || ($submitter eq {})} {
dict set details submitter $email
}
MailHeader accept_mail Accepted $desc
lappend accept_mail "Your submission has been accepted."
lappend accept_mail "The repository should appear on our web-pages soon."
MailFooter accept_mail
set accept_mail [join $accept_mail \n]
m mailer to $email [m mail generator reply $accept_mail $details]
}
}
SiteRegen
OK
}
proc ::m::glue::cmd_reject {config} {
debug.m/glue {[debug caller] | }
package require m::submission
package require m::mail::generator
package require m::mailer
package require m::reply
m db transaction {
set submissions [$config @id]
set cause [$config @cause]
set cdetails [m reply get $cause]
dict with cdetails {}
debug.m/glue {reply $cause => ($cdetails)}
# -> text
# mail
if {[$config @mail set?]} {
set mail [$config @mail]
}
m msg "Cause: $text"
foreach submission $submissions {
set details [m submission get $submission]
dict with details {}
# -> url
# email
# submitter
# when
# desc
# vcode
set name [color note $email]
if {$submitter ne {}} {
append name " ([color note $submitter])"
}
m msg " Rejected $url ($desc)"
m msg " By $name"
m submission reject $submission $text
if {!$mail} continue
m msg " Sending rejection notice to $email ..."
dict set details when [m format epoch $when]
if {![info exists $submitter] || ($submitter eq {})} {
dict set details submitter $email
}
MailHeader decline_mail Declined $desc
lappend decline_mail "We are sorry to tell you that we are declining it."
lappend decline_mail $text ;# cause
MailFooter decline_mail
set decline_mail [join $decline_mail \n]
m mailer to $email [m mail generator reply $decline_mail $details]
unset decline_mail
}
}
SiteRegen
OK
}
proc ::m::glue::cmd_drop {config} {
debug.m/glue {[debug caller] | }
package require m::submission
m db transaction {
set rejections [$config @rejections]
foreach rejection $rejections {
m msg " Dropping [color note [m submission rejected-url $rejection]]"
m submission drop $rejection
}
}
SiteRegen
OK
}
proc ::m::glue::cmd_test_cycle_mail {config} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::state
if {[$config @mail]} {
# For mailing no color control sequences in the output!
set active [cmdr color active]
cmdr color activate 0
m db transaction {
set message [ComeAroundMail [m state mail-width] [m state start-of-current-cycle] [clock seconds]]
}
cmdr color activate $active
package require m::mail::generator
package require m::mailer
m mailer to [$config @destination] [m mail generator reply $message {}]
} else {
m db transaction {
set message [ComeAroundMail [$config @tw] [m state start-of-current-cycle] [clock seconds]]
}
m msg $message
}
OK
}
proc ::m::glue::cmd_test_mail_config {config} {
debug.m/glue {[debug caller] | }
package require m::mailer
package require m::mail::generator
try {
m mailer to [$config @destination] [m mail generator test]
} on error {e o} {
m msg [color bad $e]
exit
}
OK
}
proc ::m::glue::cmd_test_vt_repository {config} {
debug.m/glue {[debug caller] | }
package require m::repo
set map [m repo known]
[table/d t {
foreach k [lsort -dict [dict keys $map]] {
set v [dict get $map $k]
$t add $v $k
}
}] show
OK
}
proc ::m::glue::cmd_test_vt_project {config} {
debug.m/glue {[debug caller] | }
package require m::project
set map [m project known]
[table/d t {
foreach k [lsort -dict [dict keys $map]] {
set v [dict get $map $k]
$t add $v $k
}
}] show
OK
}
proc ::m::glue::cmd_test_vt_reply {config} {
debug.m/glue {[debug caller] | }
package require m::reply
set map [m reply known]
[table/d t {
foreach k [lsort -dict [dict keys $map]] {
set v [dict get $map $k]
$t add $v $k
}
}] show
OK
}
proc ::m::glue::cmd_test_vt_submission {config} {
debug.m/glue {[debug caller] | }
package require m::submission
set map [m submission known]
[table/d t {
foreach k [lsort -dict [dict keys $map]] {
set v [dict get $map $k]
$t add $v $k
}
}] show
OK
}
proc ::m::glue::cmd_debug_levels {config} {
debug.m/glue {[debug caller] | }
puts [info level 0] ;# XXX TODO FILL-IN debug levels
return
}
# # ## ### ##### ######## ############# ######################
proc ::m::glue::MailFooter {mv} {
debug.m/glue {[debug caller] | }
upvar 1 $mv mail
lappend mail ""
lappend mail "Sincerely"
lappend mail " @sender@"
return
}
proc ::m::glue::MailHeader {mv label desc} {
debug.m/glue {[debug caller] | }
upvar 1 $mv mail
set title [m state site-title]
if {$title eq {}} { set title Mirror }
lappend mail "$title. $label submission of @s:url@"
lappend mail "Hello @s:submitter@"
lappend mail ""
lappend mail "Thank you for your submission of"
if {$desc ne {}} {
lappend mail " \[@s:desc@](@s:url@)"
} else {
lappend mail " @s:url@"
}
lappend mail "to $title, as of @s:when@"
lappend mail ""
return
}
proc ::m::glue::Url {config} {
debug.m/glue {[debug caller] | }
set url [$config @url]
debug.m/glue {[debug caller] | re'url = $url }
try {
set in [$config @url string]
debug.m/glue {[debug caller] | in'url = $in }
} trap {CMDR PARAMETER UNDEFINED} {} {
# This is possible for cmd_accept where the state url by
# glue::gen_url, which leaves out the string information
set in $url
}
if {$url ne $in} {
m msg "[color warning Redirected] to [color note $url]"
m msg "From [color note $in]"
}
debug.m/glue {[debug caller] | --> $url }
return $url
}
proc ::m::glue::ImportRead {label chan} {
debug.m/glue {[debug caller] | }
m msg "Reading [color note $label] ..."
return [split [string trim [read $chan]] \n]
# :: list (command)
# command :: list ('M' name) - old: 'M'irrorset
# | list ('P' name) - new: 'P'roject
# | list ('R' vcode url)
}
proc ::m::glue::ImportVerify {commands} {
debug.m/glue {}
# commands :: list (command)
# command :: list ('M' name) - old: 'M'irrorset
# | list ('P' name) - new: 'P'roject
# | list ('R' vcode url)
m msg "Verifying ..."
foreach {code name} [m vcs all] {
dict set vcs $code .
dict set vcs $name .
}
set lno 0
set maxl [llength $commands]
set lfmt %-[string length $maxl]s
set msg {}
set new {}
foreach command $commands {
incr lno
debug.m/glue {[format $lfmt $lno]: '$command'}
# strip (trailing) comments, leading & trailing whitespace
regsub -- "#.*\$" $command {} command
set command [string trim $command]
# skip empty lines
if {$command eq {}} continue
lassign $command cmd a b
switch -exact -- $cmd {
M -
P {
Ping " $command"
# M name --> a = name, b = ((empty string))
if {[llength $command] != 2} {
lappend msg "Line [format $lfmt $lno]: Bad syntax: $command"
}
}
R {
Ping " [list R $b]"
# R kind url --> a = kind, b = url
if {[llength $command] != 3} {
lappend msg "Line [format $lfmt $lno]: Bad syntax: $command"
} else {
if {![dict exists $vcs $a]} {
lappend msg "Line [format $lfmt $lno]: Unknown vcs: $command"
}
Ping+ " ..."
if {![m url ok $b resolved]} {
lappend msg "Line [format $lfmt $lno]: Bad url: $b"
} else {
#Ping+ \n
Ping " = $resolved"
# Add resolution to R commands.
lappend command $resolved
}
}
}
default {
Ping " $command"
lappend msg "Line [format $lfmt $lno]: Unknown command: $command"
}
}
lappend new $command
#Ping+ \n
}
# Start a last ping to erase the animation remnants.
Ping ""
if {[llength $msg]} {
m::cmdr::error \n\t[join $msg \n\t] IMPORT BAD
}
# Unchanged.
return $new
}
proc ::m::glue::ImportSkipKnown {commands} {
# commands :: list (command)
# command :: list ('M' name)
# | list ('R' vcode url resolved)
debug.m/glue {}
m msg "Weeding ..."
set seen {}
set lno 0
set new {}
set repo {}
foreach command $commands {
debug.m/glue {$command}
incr lno
lassign $command cmd vcs url resolved
switch -exact -- $cmd {
R {
if {$url ne $resolved} {
m msg "Line $lno: [color warning Redirected] to [color note $resolved]"
m msg "Line $lno: From [color note $url]"
}
set check [m vcs url-norm $vcs $resolved]
debug.m/glue {checking $check}
if {[m repo has $check]} {
m msg "Line $lno: [color warning Skip] known repository [color note $url]"
continue
}
if {$resolved in $repo} {
m msg "Line $lno: [color warning Skip] [color bad duplicate] [color note $url]"
continue
}
if {[dict exists $seen $resolved]} {
lassign [dict get $seen $resolved] olno m
m msg "Line $lno: [color warning Skip] [color bad duplicate] [color note $url]"
m msg "Line $lno: Belongs to [color note $m] (Line $olno)"
continue
}
dict set seen $resolved $lno
lappend x $resolved
lappend repo $vcs $resolved
}
M {
if {![llength $repo]} {
m msg "Line $lno: [color warning Skip] empty project [color note $vcs]"
set repo {}
continue
}
foreach r $x { dict lappend seen $r $vcs } ;# vcs = mname
unset x
lappend command $repo
lappend new $command
set repo {}
}
}
}
# new :: list (mset)
# mset :: list ('M' name repos)
# repos :: list (vcode1 url1 v2 u2 ...)
return $new
}
proc ::m::glue::ImportDo {dated commands} {
# commands :: list (mset)
# mset :: list ('M' name repos)
# repos :: list (vcode1 url1 v2 u2 ...)
debug.m/glue {}
if {![llength $commands]} {
m msg [color warning "Nothing to import"]
} else {
m msg "Importing [llength $commands] (finally) ..."
}
if {$dated} {
set date _[lindex [split [m format epoch [clock seconds]]] 0]
} else {
set date {}
}
foreach command $commands {
lassign $command _ msetname repos
m db transaction {
Import1 $date $msetname$date $repos
}
# signal commit
m msg [color good OK]
}
return
}
proc ::m::glue::Import1 {date mname repos} {
debug.m/glue {[debug caller] | }
# repos = list (vcode url ...)
m msg "Handling project [color note $mname] ..."
if {[llength $repos] == 2} {
lassign $repos vcode url
# The project contains only a single repository.
# We might be able to skip the merge
if {![m project has $mname]} {
# No project of the given name exists.
# Create directly in final form. Skip merge.
try {
ImportMake1 $vcode $url $mname
} trap {M VCS CHILD} {e o} {
# Revert creation of mset and repository
set repo [m rolodex top]
set mset [m repo mset $repo]
m repo remove $repo
m rolodex drop $repo
m project remove $mset
m msg "[color bad {Unable to import}] [color note $mname]: $e"
# No rethrow, the error in the child is not an error
# for the whole command. Continue importing the remainder.
}
return
}
}
# More than a single repository in this set, or the destination
# project exists. Merging is needed. And the untrusted nature
# of the input means that we cannot be sure that merging is even
# allowed.
# Two phases:
# - Create the repositories. Each in its own project, like for
# `add`. Project names are of the form `import_<date>`, plus a
# serial number. Comes with associated store.
#
# - Go over the repositories again and merge them. If a
# repository is rejected by the merge keep it separate. Retry
# merging using the rejections. The number of retries is finite
# because each round finalizes at least one project and its
# repositories of the finite supply. At the end of this phase we
# have one or more projects each with maximally merged
# repositories. Each finalized project is renamed to final form,
# based on the incoming mname and date.
set serial 0
set r {}
foreach {vcode url} $repos {
try {
set tmpname import${date}_[incr serial]
set data [ImportMake1 $vcode $url $tmpname]
dict set r $url $data
} trap {M VCS CHILD} {e o} {
# Revert creation of mset and repository
set repo [m rolodex top]
set mset [m repo mset $repo]
m repo remove $repo
m rolodex drop $repo
m project remove $mset
m msg "[color bad {Unable to use}] [color note $url]: $e\n"
# No rethrow, the error in the child is not an error
# for the whole command. Continue importing the remainder.
}
}
if {![dict size $r]} {
# All inputs fail, report and continue with the remainder
m msg "[color bad {Unable to import}] [color note $mname]: No repositories"
return
}
set rename 1
if {[m project has $mname]} {
# Targeted project exists. Make it first in the merge list.
set mset [m project id $mname]
set repos [linsert $repos 0 dummy_vcode @$mname]
dict set r @$mname [list dummy_vcs $mset dummy_store]
set rename 0
}
while on {
set remainder [lassign $repos v u]
lassign [dict get $r $u] vcsp msetp storep
m msg "Merge to $u ..."
set unmatched {}
foreach {vcode url} $remainder {
lassign [dict get $r $url] vcs mset store
try {
m msg "Merging $url"
Merge $msetp $mset
} trap {M::CMDR MISMATCH} {} {
m msg " Rejected"
lappend unmatched $vcode $url
} on error {e o} {
puts [color bad ////////////////////////////////////////]
puts [color bad $e]
puts [color bad $o]
puts [color bad ////////////////////////////////////////]
}
}
if {$rename} {
# Rename primary mset to final form.
Rename $msetp [MakeName $mname]
set rename 0
}
if {![llength $unmatched]} break
# Retry to merge the leftovers. Note, each iteration
# finalizes at least one project, ensuring termination of the
# loop.
set repos $unmatched
set rename 1
}
m rolodex commit
return
}
proc ::m::glue::ImportMake1 {vcode url base} {
debug.m/glue {[debug caller] | }
set vcs [m vcs id $vcode]
set tmpname [MakeName $base]
set project [m project add $tmpname]
set url [m vcs url-norm $vcode $url]
set vcode [m vcs code $vcs]
m msg "> [string totitle $vcode] repository [color note $url]"
# -----------------------
# vcs project url
lassign [AddStoreRepo $vcs $vcode $tmpname $url $project] repo forks
set store [m repo store $repo]
# Forks are not processed. It is expected that forks are in the import file.
# The next update of the primary will link them to the origin.
set nforks [llength $forks]
if {$nforks} {
m msg " [color warning "Forks found ($nforks), ignored"]"
}
m rolodex push $repo
return [list $vcs $project $store]
}
proc ::m::glue::Add {config} {
debug.m/glue {[debug caller] | }
set url [Url $config]
set vcs [$config @vcs]
set vcode [$config @vcs-code]
set name [$config @name]
set url [m vcs url-norm $vcode $url]
# __Attention__: Cannot move the url normalization into a
# when-set clause of the parameter. That generates a
# dependency cycle:
#
# url <- vcode <- vcs <- url
m msg "Attempting to add"
m msg " Repository [color note $url]"
m msg " Managed by [color note [m vcs name $vcs]]"
m msg "New"
m msg " Project [color note $name]"
if {[m repo has $url]} {
m::cmdr::error \
"Repository already present" \
HAVE_ALREADY REPOSITORY
}
if 0 {if {[m project has $name]} {
m::cmdr::error \
"Name already present" \
HAVE_ALREADY NAME
}}
# Relevant entities
# 1. repository
# 2. store
# 3. project
#
# As the repository references the other two these have to be initialized first.
# The creation of the repository caps the process.
# Issues roll database changes back.
m msg "Actions ..."
# ---------------------------------- Project
if {![m project has $name]} {
m msg* " Setting up the project ... "
set project [m project add $name]
OKx
} else {
m msg " Project is known"
}
lassign [AddStoreRepo $vcs $vcode $name $url $project] repo forks
# ---------------------------------- Forks
if {$forks ne {}} {
set threshold 22
set nforks [llength $forks]
m msg "Found [color note $nforks] forks to track."
if {![$config @track-forks] && ($nforks > $threshold)} {
m msg [color warning "Auto-tracking threshold of $threshold forks exceeded"]
m::cmdr::error "Please confirm using [color note --track-forks] that this many forks should be tracked." \
TRACKING-THRESHOLD
}
AddForks $forks $repo $vcs $vcode $name $project
}
# ----------------------------------
m msg "Setting new primary as current repository"
m rolodex push $repo
m rolodex commit
return
}
proc ::m::glue::AddForks {forks repo vcs vcode name project} {
debug.m/glue {[debug caller] | }
set nforks [llength $forks]
set format %-[string length $nforks]d
set pad [string repeat " " [expr {3+[string length $nforks]}]]
foreach fork $forks {
incr k
m msg " [color cyan "([format $format $k])"] Fork [color note $fork] ... "
if {[m repo has $fork]} {
m msg " $pad[color note "Already known, claiming it"]"
# NOTE: The fork exists in a different project. We
# leave that part alone. The ERD allows that, a fork
# and its origin do not have to be in the same
# project.
m repo claim $repo [m repo id $fork]
continue
}
# Note: Fork urls have to be validated, same as the primary location.
if {![m url ok $fork xr]} {
m msg " [color warning {Not reachable}], might be private or gone"
m msg " Ignored"
continue
}
AddStoreRepo $vcs $vcode $name $fork $project $repo
}
return
}
proc ::m::glue::AddStoreRepo {vcs vcode name url project {origin {}}} {
debug.m/glue {[debug caller] | }
# ---------------------------------- Store
m msg* " Setting up the $vcode store ... "
lassign [m store add $vcs $name $url] \
store duration commits size forks
# id seconds int int list(url)
set x [expr {($commits == 1) ? "commit" : "commits"}]
m msg "[color good OK] in [color note [m format interval $duration]] ($commits $x, $size KB)"
# ---------------------------------- Repository
m msg* " Creating repository ... "
set repo [m repo add $vcs $project $store $url $duration $origin]
OKx
return [list $repo $forks]
}
proc ::m::glue::InvalE {label key} {
set v [m state $key]
return [list [Inval $label {$v ne {}}] $v]
}
proc ::m::glue::Inval {x isvalid} {
debug.m/glue {[debug caller] | }
if {[uplevel 1 [list ::expr $isvalid]]} {
return $x
} else {
return [color bad $x]
}
}
# TODO: Bool, Date, Size => utility package
proc ::m::glue::Bool {flag} {
debug.m/glue {[debug caller] | }
return [expr {$flag ? "[color good on]" : "[color bad off]"}]
}
proc ::m::glue::ShowCurrent {config} {
debug.m/glue {[debug caller] | }
package require m::repo
package require m::rolodex
m db transaction {
set rolodex [m rolodex get]
set n [llength $rolodex]
if {$n} {
set id -1
set series {}
foreach r $rolodex {
incr id
set rinfo [m repo get $r]
dict with rinfo {}
# -> url : repo url
# vcs : vcs id
# -> vcode : vcs code
# project: project id
# -> name : project name
# store : id of backing store for repo
lappend tag @$id
if {$id == ($n-2)} { lappend tag @p }
if {$id == ($n-1)} { lappend tag @c }
lappend series [list $tag $url $name $vcode]
unset tag
}
}
}
if {$n} {
lassign [TruncW \
{{} {} {} {}} \
{0 1 3 0} \
$series [$config @tw]] \
titles series
[table t $titles {
$t borders 0
$t headers 0
foreach row $series {
$t add {*}[C $row 1 note] ;# 1 => url
}
}] show
}
return
}
proc ::m::glue::OK {} {
debug.m/glue {[debug caller] | }
m msg [color good OK]
return -code return
}
proc ::m::glue::OKx {} {
debug.m/glue {[debug caller] | }
m msg [color good OK]
}
proc ::m::glue::MakeName {prefix} {
debug.m/glue {[debug caller] | }
if {![m project has $prefix]} { return $prefix }
set n 1
while {[m project has ${prefix}#$n]} { incr n }
return "${prefix}#$n"
}
proc ::m::glue::ComeAroundMail {width current newcycle} {
debug.m/glue {[debug caller] | }
package require m::db
package require m::state
package require m::store
package require m::format
# Get updates and convert into a series for the table. A series we
# can compress width-wise before formatting.
set series {}
foreach row [m store updates] {
dict with row {}
# store mname vcode changed updated created size active remote
# sizep commits commitp mins maxs lastn
if {$created eq "."} continue ;# ignore separations
if {$changed < $current} continue ;# older cycle
set dcommit [DeltaCommit $commits $commitp]
set dsize [DeltaSize $size $sizep]
set changed [m format epoch/short $changed]
set spent [LastTime $lastn]
lappend series [list $changed $vcode $mname $spent $dsize $dcommit]
}
lappend mail "\[[info hostname]\] Cycle Report."
lappend mail "Cycle\nFrom [clock format $current]\nTo [clock format $newcycle]"
set n [llength $series]
if {!$n} {
lappend mail "Found no changes."
} else {
lappend mail "Found @/n/@ changed repositories:\n"
lassign [TruncW \
{Changed VCS Project Time Size Commits} \
{0 0 1 0 0 0} \
$series \
$width] \
titles series
table t $titles {
foreach row $series {
$t add {*}$row
}
}
lappend mail [$t show return]
$t destroy
}
MailFooter mail
return [string map [list @/n/@ $n] [join $mail \n]]
}
proc ::m::glue::ComeAround {newcycle} {
debug.m/glue {[debug caller] | }
# Called when the update cycle comes around back to the start.
# Creates a mail reporting on all the projects which where
# changed in the previous cycle.
set current [m state start-of-current-cycle]
m state start-of-previous-cycle $current
m state start-of-current-cycle $newcycle
m msg "Cycle complete, coming around and starting new ..."
set email [m state report-mail-destination]
if {$email eq {}} {
debug.m/glue {[debug caller] | Skipping report without destination}
# Nobody to report to, skipping report
m msg "- [color warning {Skipping mail report, no destination}]"
return
}
package require m::mail::generator
package require m::mailer
m msg "- [color good "Mailing report to"] [color note $email]"
set comearound [ComeAroundMail [m state mail-width] $current $newcycle]
m mailer to $email [m mail generator reply $comearound {}]
m msg [color good OK]
return
}
proc ::m::glue::UpdateRepos {start now repos} {
debug.m/glue {[debug caller] | }
set n [llength $repos]
if {$n} {
# The note below is not shown when the user explicitly
# specifies the repositories to process. Because that is
# outside any cycle.
return $repos
}
set take [m state take]
set nrepo [m repo count]
set npending [m repo count-pending]
m msg "In cycle started on [m format epoch $start]: $take/$npending/$nrepo"
# No repositories specified.
# Pull repositories directly from pending
return [m repo take-pending $take \
::m::glue::ComeAround $now]
}
proc ::m::glue::Dedup {values} {
debug.m/glue {[debug caller] | }
# While keeping the order
set res {}
set have {}
foreach v $values {
if {[dict exist $have $v]} continue
lappend res $v
dict set have $v .
}
return $res
}
proc ::m::glue::MergeFill {msets} {
debug.m/glue {[debug caller] | }
set n [llength $msets]
if {!$n} {
# No project. Use the projects for current and previous
# repository as merge target and source
set target [m rolodex top]
if {$target eq {}} {
m::cmdr::error \
"No current repository to indicate merge target" \
MISSING CURRENT
}
set origin [m rolodex next]
if {$origin eq {}} {
m::cmdr::error \
"No previously current repository to indicate merge source" \
MISSING PREVIOUS
}
lappend msets [m repo mset $target] [m repo mset $origin]
return $msets
}
if {$n == 1} {
# A single project is the merge origin. Use the project of the
# current repository as merge target.
set target [m rolodex top]
if {$target eq {}} {
m::cmdr::error \
"No current repository to indicate merge target" \
MISSING CURRENT
}
return [linsert $msets 0 [m repo mset $target]]
}
return $msets
}
proc ::m::glue::Rename {mset newname} {
debug.m/glue {[debug caller] | }
m project rename $mset $newname
# TODO MAYBE: stuff cascading logic into `mset rename` ?
foreach store [m project stores $mset] {
m store rename $store $newname
}
return
}
proc ::m::glue::Merge {target origin} {
debug.m/glue {[debug caller] | }
# Target and origin are projects
#
# - Check that all the origin's repositories fit into the target.
# This is done by checking the backing stores of the vcs in use
# for compatibility.
#
# - When they do the stores are moved or merged, depending on
# - presence of the associated vcs in the target.
set vcss [m project used-vcs $origin]
# Check that all the origin's repositories fit into the target.
foreach vcs $vcss {
# Ignore vcs which are not yet used by the target
# Assumed to be compatible.
if {![m store has $vcs $target]} continue
# Get the two stores, and check for compatibility
set tstore [m store id $vcs $target]
set ostore [m store id $vcs $origin]
if {[m store check $tstore $ostore]} continue
m::cmdr::error \
"Merge rejected due to [m vcs name $vcs] mismatch" \
MISMATCH
}
# Move or merge the stores, dependong presence in the target.
foreach vcs $vcss {
set ostore [m store id $vcs $origin]
if {![m store has $vcs $target]} {
m store move $ostore $target
} else {
m store merge [m store id $vcs $target] $ostore
}
}
# Move the repositories, drop the origin set, empty after the move
m repo move/project $origin $target
m project remove $origin
return
}
proc ::m::glue::MailConfigShow {t {prefix {}}} {
debug.m/glue {[debug caller] | }
set u [m state mail-user]
set s [m state mail-sender]
$t add ${prefix}Host [m state mail-host]
$t add ${prefix}Port [m state mail-port]
$t add ${prefix}User [Inval $u {$u ne "undefined"}]
$t add ${prefix}Pass [m state mail-pass]
$t add ${prefix}TLS [m state mail-tls]
$t add ${prefix}Sender [Inval $s {$s ne "undefined"}]
$t add ${prefix}Header [m state mail-header]
$t add ${prefix}Footer [m state mail-footer]
$t add ${prefix}Width [m state mail-width]
$t add ${prefix}Debug [m state mail-debug]
return
}
proc ::m::glue::ReplyConfigShow {} {
debug.m/glue {[debug caller] | }
[table t {{} Name Mail Text} {
foreach {name default mail text} [m reply all] {
set mail [expr {$mail ? "*" : ""}]
set default [expr {$default ? "#" : ""}]
$t add $default [color note $name] $mail $text
}
}] show
return
}
proc ::m::glue::SiteRegen {} {
debug.m/glue {[debug caller] | }
package require m::state
if {![m state site-active]} return
package require m::web::site
m web site build silent
return
}
proc ::m::glue::SiteConfigShow {t {prefix {}}} {
debug.m/glue {[debug caller] | }
$t add ${prefix}State [Bool [m state site-active]]
#
$t add {*}[InvalE "${prefix}Location" site-store]
$t add {*}[InvalE ${prefix}Url site-url]
$t add ${prefix}Logo [m state site-logo]
$t add {*}[InvalE ${prefix}Title site-title]
#
$t add ${prefix}Manager {}
$t add {*}[InvalE "${prefix}- Name" site-mgr-name]
$t add {*}[InvalE "${prefix}- Mail" site-mgr-mail]
#
$t add ${prefix}Related {}
$t add "${prefix}- Url" [m state site-related-url]
$t add "${prefix}- Label" [m state site-related-label]
return
}
proc ::m::glue::SiteEnable {flag} {
debug.m/glue {[debug caller] | }
if {[m state site-active] != $flag} {
if {$flag} SiteConfigValidate
m state site-active $flag
set flag [expr {$flag ? "Activated" : "Disabled"}]
} else {
set flag [expr {$flag ? "Still active" : "Still disabled"}]
}
m msg "$flag web site generation"
return
}
proc ::m::glue::SiteConfigValidate {} {
debug.m/glue {[debug caller] | }
set m {}
set ok 1
# site-logo :: Optional.
foreach {k label} {
site-store {No location for generation result}
site-mgr-name {No manager specified}
site-mgr-mail {No manager mail specified}
site-title {No title specified}
site-url {No publication url specified}
} {
if {[m state $k] ne ""} continue
lappend m "- $label"
set ok 0
}
if {$ok} return
m msg [join $m \n]
m::cmdr::error "Unable to activate site generation" \
SITE CONFIG INCOMPLETE
}
proc ::m::glue::Ping+ {text} {
debug.m/glue {[debug caller] | }
# Extend current line with more text, stay on the line, except
# when text does not.
puts -nonewline stdout $text
flush stdout
return
}
proc ::m::glue::Ping {text} {
debug.m/glue {[debug caller] | }
# Move to start of line, erase all, write new text, stay on the
# line, except when text does not.
puts -nonewline stdout \r\033\[0K$text
flush stdout
return
}
proc ::m::glue::C {row index color} {
return [lreplace $row $index $index [color $color [lindex $row $index]]]
}
proc ::m::glue::W {wv} {
upvar 1 $wv wc
set cols [lsort -integer [array names wc]]
set ww {}
foreach c $cols { lappend ww $wc($c) }
return $ww
}
proc ::m::glue::TruncH {series height} {
debug.m/glue {[debug caller] | }
incr height -4 ; # table overhead (header and borders)
incr height -3 ; # lines before and after table (prompt with command + OK)
if {[llength $series] > $height} {
set series [lrange $series 0 ${height}-2]
lappend series [lrepeat [llength [lindex $series 0]] ...]
}
return $series
}
##
## TODO column specific minimum widths
## TODO column specific shaving (currently all on the right, urls: left better, or middle)
## TODO column specific shave commands (ex: size rounding)
## TODO
## TODO
##
proc ::m::glue::TruncW {titles weights series width} {
# series :: list (row)
# row :: list (0..n-1 str)
# weights :: list (0..k-1 int)
# titles :: list (0..n-1 str) - Hard min (for now: include in full width)
# width :: int 'terminal width'
#
# n < k => Ignore superfluous weights.
# n > k => Pad to the right with weight 0.
#
# weight -1: Do not touch at all. (Colorized?!)
set n [llength [lindex $series 0]]
set k [llength $weights]
debug.m/glue { terminal : $width }
debug.m/glue { len(series) : [llength $series] }
debug.m/glue { len(row) : $n }
debug.m/glue { len(weights) : $k ($weights)}
if {$n < $k} {
set d [expr {$k - $n}]
set weights [lreplace $weights end-$d end]
# TODO: Check arith (off by x ?)
}
if {$n > $k} {
set d [expr {$n - $k}]
lappend weights {*}[lrepeat $d 0]
}
# Remove table border overhead to get usable terminal space
set width [expr {$width - (3*$n+1)}]
debug.m/glue { terminal' : $width (-[expr {3*$n+1}]) }
debug.m/glue { weights' : ($weights)}
# Compute series column widths (max len) for all columns. If the
# total width is larger than width we have to shrink by weight.
# Note: Min column width after shrinking is 6 (because we want to
# show something for each column). If shrink by weight goes below
# this min width bump up to it and remove the needed characters
# from the weight 0 columns, but not below min width.
set min 6
while {$k} { incr k -1 ; set wc($k) 0 }
foreach row [linsert $series 0 $titles] {
set col 0
foreach el $row {
set n [string length $el]
if {$n > $wc($col)} { set wc($col) $n }
incr col
}
}
debug.m/glue { col.widths = [W wc] }
# max width over all rows.
set fw 0
foreach {_ v} [array get wc] { incr fw $v }
debug.m/glue { full = $fw vs terminal $width }
# Nothing to do if the table fits already
if {$fw <= $width} { return [list $titles $series] }
# No fit, start shrinking.
# Sum of weights to apportion
set tw 0
foreach w $weights { if {$w <= 0} continue ; incr tw $w }
# Number of characters over the allowed width.
set over [expr {$fw - $width}]
debug.m/glue { over : $over }
# Shrink columns per weight
set col 0 ; set removed 0
foreach w $weights {
set c $col ; incr col
if {$w <= 0} {
debug.m/glue { ($col): skip }
continue
}
set drop [format %.0f [expr {double($over * $w)/$tw}]]
debug.m/glue { ($col): drop $drop int(($over*$w)/$tw)) }
incr removed $drop
incr wc($c) -$drop
}
# --assert: removed >= over
debug.m/glue { removed : $removed }
# Rounding may cause removed < over, leaving too many characters behind.
# Run a constant shaver, on the weighted cols
set over [expr {$over - $removed}]
if {$over} { ShaveWeighted wc $weights $over }
debug.m/glue { col.widths = [W wc] }
# If a weighted column has become to small, i.e. less than the
# allowed min, in the above we bump it back to that width and will
# shave these then from other columns.
set col 0
set under 0
foreach w $weights {
set c $col ; incr col
if {($w <= 0) || ($wc($c) >= $min)} continue
incr under [expr {$min - $wc($c)}]
set wc($c) $min
}
debug.m/glue { under : $under }
debug.m/glue { col.widths = [W wc] }
# Claw back the added characters from other columns now, as much
# as we can. We try to shrink other weighted columns first before
# goign for the unweighted, i.e. strongly fixed ones.
if {$under} { set under [ShaveWeighted wc $weights $under] }
if {$under} { set under [ShaveUnweighted wc $weights $under] }
debug.m/glue { col.widths = [W wc] }
# At last, truncate the series elements to the chosen column
# widths. Same for the titles.
set new {}
foreach row $series {
set col 0
set newrow {}
foreach el $row {
if {[string length $el] > $wc($col)} {
set el [string range $el 0 $wc($col)-1]
}
lappend newrow $el
incr col
}
lappend new $newrow
}
set col 0
set newtitles {}
foreach el $titles {
if {[string length $el] > $wc($col)} {
set el [string range $el 0 $wc($col)-1]
}
lappend newtitles $el
incr col
}
return [list $newtitles $new]
}
proc ::m::glue::ShaveWeighted {wv weights shave} {
set min 6 ;# todo place in common
upvar 1 $wv wc
set changed 1
while {$changed} {
set changed 0
set col 0
foreach w $weights {
set c $col ; incr col
if {$w <= 0} continue
if {$wc($c) <= $min} continue
incr wc($c) -1
incr shave -1
set changed 1
if {!$shave} { return 0 }
}
}
return $shave
}
proc ::m::glue::ShaveUnweighted {wv weights shave} {
set min 6 ;# todo place in common
upvar 1 $wv wc
set changed 1
while {$changed} {
set changed 0
set col 0
foreach w $weights {
set c $col ; incr col
if {$w != 0} continue
if {$wc($c) <= $min} continue
incr wc($c) -1
incr shave -1
set changed 1
if {!$shave} { return 0 }
}
}
return $shave
}
# # ## ### ##### ######## ############# ######################
## Delta formatting, various kinds (size, commits, time spent)
## With and without previous. Always current and delta.
proc ::m::glue::LastTime {lastn} {
return [m format interval [lindex [split [string trim $lastn ,] ,] end]]
}
proc ::m::glue::StatsTime {mins maxs lastn} {
set mins [expr {$mins < 0 ? "+Inf" : [m format interval $mins]}]
set maxs [m format interval $maxs]
# See also ::m::repo::times, ::m::web::site::Store
append text "$mins ... $maxs"
set lastn [m format win $lastn]
set n [llength $lastn]
if {!$n} { return $text }
set lastn [m format win-trim $lastn [m state store-window-size]]
set n [llength $lastn]
set total [expr [join $lastn +]]
set avg [m format interval [format %.0f [expr {double($total)/$n}]]]
append text " \[avg (last $n) $avg ([join $lastn ,]))]"
return $text
}
proc ::m::glue::DeltaSizeFull {current previous} {
append text [m format size $current]
if {$previous != $current} {
if {$current < $previous} {
# shrink
set color bad
set delta -[m format size [expr {$previous - $current}]]
} else {
# grow
set color note
set delta +[m format size [expr {$current - $previous}]]
}
set dprev [m format size $previous]
append text " (" [color $color "$dprev ($delta)"] ")"
}
return $text
}
proc ::m::glue::DeltaSize {current previous} {
append text [m format size $current]
if {$previous != $current} {
if {$current < $previous} {
# shrink
set color bad
set delta -[m format size [expr {$previous - $current}]]
} else {
# grow
set color note
set delta +[m format size [expr {$current - $previous}]]
}
append text " (" [color $color "$delta"] ")"
}
return $text
}
proc ::m::glue::DeltaCommitFull {current previous} {
if {$previous == $current} { return $current }
set delta [expr {$current - $previous}]
if {$delta < 0} {
set color bad
} else {
# delta > 0
set color note
set delta +$delta
}
append text $current " (" [color $color "$previous ($delta)"] ")"
return $text
}
proc ::m::glue::DeltaCommit {current previous} {
if {$previous == $current} { return $current }
set delta [expr {$current - $previous}]
if {$delta < 0} {
set color bad
} else {
# delta > 0
set color note
set delta +$delta
}
append text $current " (" [color $color "$delta"] ")"
return $text
}
# # ## ### ##### ######## ############# ######################
return