1# -*- tcl -*- 2# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> 3## 4# ### 5 6package require sak::animate 7package require sak::feedback 8package require sak::color 9 10getpackage textutil::repeat textutil/repeat.tcl 11getpackage interp interp/interp.tcl 12getpackage struct::set struct/sets.tcl 13getpackage struct::list struct/list.tcl 14 15namespace eval ::sak::validate::versions { 16 namespace import ::textutil::repeat::blank 17 namespace import ::sak::color::* 18 namespace import ::sak::feedback::! 19 namespace import ::sak::feedback::>> 20 namespace import ::sak::feedback::+= 21 namespace import ::sak::feedback::= 22 namespace import ::sak::feedback::=| 23 namespace import ::sak::feedback::log 24 namespace import ::sak::feedback::summary 25 rename summary sum 26} 27 28# ### 29 30proc ::sak::validate::versions {modules mode stem} { 31 versions::run $modules $mode $stem 32 versions::summary 33 return 34} 35 36proc ::sak::validate::versions::run {modules mode stem} { 37 sak::feedback::init $mode $stem 38 sak::feedback::first log "\[ Versions \] ====================================================" 39 sak::feedback::first warn "\[ Versions \] ====================================================" 40 sak::feedback::first fail "\[ Versions \] ====================================================" 41 42 # Preprocessing of module names to allow better formatting of the 43 # progress output, i.e. vertically aligned columns 44 45 # Per module 46 # - List modules without package index (error) 47 # - List packages provided missing from pkgIndex.tcl 48 # - List packages in the pkgIndex.tcl, but not provided. 49 # - List packages where provided and indexed versions differ. 50 51 Count $modules 52 MapPackages 53 54 InitCounters 55 foreach m $modules { 56 # Skip tcllibc shared library, not a module. 57 if {[string equal $m tcllibc]} continue 58 59 InitModuleCounters 60 ! 61 log "@@ Module $m" 62 Head $m 63 64 if {![llength [glob -nocomplain [file join [At $m] pkgIndex.tcl]]]} { 65 +e "No package index" 66 } else { 67 # Compare package provided to ifneeded. 68 69 struct::list assign \ 70 [struct::set intersect3 [Indexed $m] [Provided $m]] \ 71 compare only_indexed only_provided 72 73 foreach p [lsort -dict $only_indexed ] { +w "Indexed/No Provider: $p" } 74 foreach p [lsort -dict $only_provided] { +w "Provided/Not Indexed: $p" } 75 76 foreach p [lsort -dict $compare] { 77 set iv [IndexedVersions $m $p] 78 set pv [ProvidedVersions $m $p] 79 if {[struct::set equal $iv $pv]} continue 80 81 struct::list assign \ 82 [struct::set intersect3 $pv $iv] \ 83 __ pmi imp 84 85 +w "Indexed </> Provided: $p \[<$imp </> $pmi\]" 86 } 87 } 88 ModuleSummary 89 } 90 return 91} 92 93proc ::sak::validate::versions::summary {} { 94 Summary 95 return 96} 97 98# ### 99 100proc ::sak::validate::versions::MapPackages {} { 101 variable pkg 102 array unset pkg * 103 104 ! 105 += Package 106 foreach {pname pdata} [ipackages] { 107 = "$pname ..." 108 foreach {pvlist pmodule} $pdata break 109 lappend pkg(mi,$pmodule) $pname 110 lappend pkg(vi,$pmodule,$pname) $pvlist 111 112 foreach {pname pvlist} [ppackages $pmodule] { 113 lappend pkg(mp,$pmodule) $pname 114 lappend pkg(vp,$pmodule,$pname) $pvlist 115 } 116 } 117 ! 118 =| {Packages mapped ...} 119 return 120} 121 122proc ::sak::validate::versions::Provided {m} { 123 variable pkg 124 return [lsort -dict $pkg(mp,$m)] 125} 126 127proc ::sak::validate::versions::Indexed {m} { 128 variable pkg 129 if {![info exists pkg(mi,$m)]} { return {} } 130 return [lsort -dict $pkg(mi,$m)] 131} 132 133proc ::sak::validate::versions::ProvidedVersions {m p} { 134 variable pkg 135 return [lsort -dict $pkg(vp,$m,$p)] 136} 137 138proc ::sak::validate::versions::IndexedVersions {m p} { 139 variable pkg 140 return [lsort -dict $pkg(vi,$m,$p)] 141} 142 143### 144 145proc ::sak::validate::versions::+e {msg} { 146 variable merrors ; incr merrors 147 variable errors ; incr errors 148 log "@@ ERROR $msg" 149 return 150} 151 152proc ::sak::validate::versions::+w {msg} { 153 variable mwarnings ; incr mwarnings 154 variable warnings ; incr warnings 155 log "@@ WARN $msg" 156 return 157} 158 159proc ::sak::validate::versions::Count {modules} { 160 variable maxml 0 161 ! 162 foreach m [linsert $modules 0 Module] { 163 = "M $m" 164 set l [string length $m] 165 if {$l > $maxml} {set maxml $l} 166 } 167 =| "Validate versions (indexed vs. provided) ..." 168 return 169} 170 171proc ::sak::validate::versions::Head {m} { 172 variable maxml 173 += ${m}[blank [expr {$maxml - [string length $m]}]] 174 return 175} 176 177### 178 179proc ::sak::validate::versions::InitModuleCounters {} { 180 variable merrors 0 181 variable mwarnings 0 182 return 183} 184 185proc ::sak::validate::versions::ModuleSummary {} { 186 variable merrors 187 variable mwarnings 188 189 set err "E [F $merrors]" 190 set wrn "W [F $mwarnings]" 191 192 if {$mwarnings} { set wrn [=yel $wrn] ; >> warn } 193 if {$merrors} { set err [=red $err] ; >> fail } 194 195 =| "~~ $err $wrn" 196 return 197} 198 199### 200 201proc ::sak::validate::versions::InitCounters {} { 202 variable errors 0 203 variable warnings 0 204 return 205} 206 207proc ::sak::validate::versions::Summary {} { 208 variable errors 209 variable warnings 210 211 set err [F $errors] 212 set wrn [F $warnings] 213 214 if {$errors} { set err [=red $err] } 215 if {$warnings} { set wrn [=yel $wrn] } 216 217 sum "" 218 sum "Versions statistics" 219 sum "#Errors: $err" 220 sum "#Warnings: $wrn" 221 return 222} 223 224### 225 226proc ::sak::validate::versions::F {n} { format %6d $n } 227 228### 229 230proc ::sak::validate::versions::At {m} { 231 global distribution 232 return [file join $distribution modules $m] 233} 234 235# ### 236 237namespace eval ::sak::validate::versions { 238 # Max length of module names and patchlevel information. 239 variable maxml 0 240 241 # Counters across all modules 242 variable errors 0 ; # Number of errors found (= modules without pkg index) 243 variable warnings 0 ; # Number of warings 244 245 # Same counters, per module. 246 variable merrors 0 247 variable mwarnings 0 248 249 # Map from modules to packages and their versions. 250 variable pkg 251 array set pkg {} 252} 253 254## 255# ### 256 257package provide sak::validate::versions 1.0 258