readme.tcl
1# -*- tcl -*-
2# (C) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
3##
4# ###
5
6namespace eval ::sak::readme {}
7
8# ###
9
10proc ::sak::readme::usage {} {
11 package require sak::help
12 puts stdout \n[sak::help::on readme]
13 exit 1
14}
15
16proc ::sak::readme::run {} {
17 global package_name package_version
18
19 getpackage struct::set struct/sets.tcl
20 getpackage struct::matrix struct/matrix.tcl
21 getpackage textutil::adjust textutil/adjust.tcl
22
23 # package -> list(version)
24 set old_version [loadoldv [location_PACKAGES]]
25 array set releasep [loadpkglist [location_PACKAGES]]
26 array set currentp [ipackages]
27
28 # Determine which packages are potentially changed, from the set
29 # of modules touched since the last release, as per their
30 # changelog ... (future: md5sum of files in a module, and
31 # file/package association).
32
33 set modifiedm [modified-modules]
34 array set changed {}
35 foreach p [array names currentp] {
36 foreach {vlist module} $currentp($p) break
37 set currentp($p) $vlist
38 set changed($p) [struct::set contains $modifiedm $module]
39 }
40
41 LoadNotes
42
43 # Containers for results
44 struct::matrix NEW ; NEW add columns 4 ; # module, package, version, notes
45 struct::matrix CHG ; CHG add columns 5 ; # module, package, old/new version, notes
46 struct::matrix ICH ; ICH add columns 5 ; # module, package, old/new version, notes
47 struct::matrix CNT ; CNT add columns 5;
48 set UCH {}
49
50 NEW add row {Module Package {New Version} Comments}
51
52 CHG add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}]
53 CHG add row {Module Package {Old Version} {New Version} Comments}
54
55 ICH add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}]
56 ICH add row {Module Package {Old Version} {New Version} Comments}
57
58 set newp {} ; set chgp {} ; set ichp {}
59 set newm {} ; set chgm {} ; set ichm {} ; set uchm {}
60 set nm 0
61 set np 0
62
63 # Process all packages in all modules ...
64 foreach m [lsort -dict [modules]] {
65 puts stderr ...$m
66 incr nm
67
68 foreach name [lsort -dict [Provided $m]] {
69 #puts stderr ......$p
70 incr np
71
72 # Define list of versions, if undefined so far.
73 if {![info exists currentp($name)]} {
74 set currentp($name) {}
75 }
76
77 # Detect and process new packages.
78
79 if {![info exists releasep($name)]} {
80 # New package.
81 foreach v $currentp($name) {
82 puts stderr .........NEW
83 NEW add row [list $m $name $v [Note $m $name]]
84 lappend newm $m
85 lappend newp $name
86 }
87 continue
88 }
89
90 # The package is not new, but possibly changed. And even
91 # if the version has not changed it may have been, this is
92 # indicated by changed(), which is based on the ChangeLog.
93
94 set vequal [struct::set equal $releasep($name) $currentp($name)]
95 set note [Note $m $name]
96
97 if {$vequal && ($note ne {})} {
98 if {$note eq "---"} {
99 # The note declares the package as unchanged.
100 puts stderr .........UNCHANGED/1
101 lappend uchm $m
102 lappend UCH $name
103 } else {
104 # Note for package without version changes => must be invisible
105 puts stderr .........INVISIBLE-CHANGE
106 Enter $m $name $note ICH
107 lappend ichm $m
108 lappend ichp $name
109 }
110 continue
111 }
112
113 if {!$changed($name) && $vequal} {
114 # Versions are unchanged, changelog also indicates no
115 # change. No particular attention here.
116
117 puts stderr .........UNCHANGED/2
118 lappend uchm $m
119 lappend UCH $name
120 continue
121 }
122
123 if {$changed($name) && !$vequal} {
124 # Both changelog and version number indicate a
125 # change. Small alert, have to classify the order of
126 # changes. But not if there is a note, this is assumed
127 # to be the classification.
128
129 if {$note eq {}} {
130 set note "\t=== Classify changes."
131 }
132 Enter $m $name $note
133 lappend chgm $m
134 lappend chgp $name
135 continue
136 }
137
138 # Changed according to ChangeLog, Version is not. ALERT.
139 # or: Versions changed, but according to changelog nothing
140 # in the code. ALERT.
141
142 # Suppress the alert if we have a note, and dispatch per
143 # the note's contents (some tags are special, instructions
144 # to us here).
145
146 if {($note eq {})} {
147 if {$changed($name)} {
148 # Changed according to ChangeLog, Version is not. ALERT.
149 set note "\t<<< MISMATCH. Version ==, ChangeLog ++"
150 } else {
151 set note "\t<<< MISMATCH. ChangeLog ==, Version ++"
152 }
153 }
154
155 Enter $m $name $note
156 lappend chgm $m
157 lappend chgp $name
158 }
159 }
160
161 # .... process the matrices and others results, make them presentable ...
162
163 set newp [llength [lsort -uniq $newp]]
164 set newm [llength [lsort -uniq $newm]]
165 if {$newp} {
166 CNT add row [list $newp {new packages} in $newm modules]
167 }
168
169 set chgp [llength [lsort -uniq $chgp]]
170 set chgm [llength [lsort -uniq $chgm]]
171 if {$chgp} {
172 CNT add row [list $chgp {changed packages} in $chgm modules]
173 }
174
175 set ichp [llength [lsort -uniq $ichp]]
176 set ichm [llength [lsort -uniq $ichm]]
177 if {$ichp} {
178 CNT add row [list $ichp {internally changed packages} in $ichm modules]
179 }
180
181 set uchp [llength [lsort -uniq $UCH]]
182 set uchm [llength [lsort -uniq $uchm]]
183 if {$uchp} {
184 CNT add row [list $uchp {unchanged packages} in $uchm modules]
185 }
186
187 CNT add row [list $np {packages, total} in $nm {modules, total}]
188
189 Header Overview
190 puts ""
191 if {[CNT rows] > 0} {
192 puts [Indent " " [Detrail [CNT format 2string]]]
193 }
194 puts ""
195
196 if {[NEW rows] > 1} {
197 Header "New in $package_name $package_version"
198 puts ""
199 Sep NEW - [Clean NEW 1 0]
200 puts [Indent " " [Detrail [NEW format 2string]]]
201 puts ""
202 }
203
204 if {[CHG rows] > 2} {
205 Header "Changes from $package_name $old_version to $package_version"
206 puts ""
207 Sep CHG - [Clean CHG 2 0]
208 puts [Indent " " [Detrail [CHG format 2string]]]
209 puts ""
210 }
211
212 if {[ICH rows] > 2} {
213 Header "Invisible changes (documentation, testsuites)"
214 puts ""
215 Sep ICH - [Clean ICH 2 0]
216 puts [Indent " " [Detrail [ICH format 2string]]]
217 puts ""
218 }
219
220 if {[llength $UCH]} {
221 Header Unchanged
222 puts ""
223 puts [Indent " " [textutil::adjust::adjust \
224 [join [lsort -dict $UCH] {, }] -length 64]]
225 }
226
227 variable legend
228 puts $legend
229 return
230}
231
232proc ::sak::readme::Header {s {sep =}} {
233 puts $s
234 puts [string repeat $sep [string length $s]]
235 return
236}
237
238proc ::sak::readme::Enter {m name note {mat CHG}} {
239 upvar 1 currentp currentp releasep releasep
240
241 # To handle multiple versions we match the found versions up by
242 # major version. We assume that we have only one version per major
243 # version. This allows us to detect changes within each major
244 # version, new major versions, etc.
245
246 array set om {} ; foreach v $releasep($name) {set om([lindex [split $v .] 0]) $v}
247 array set cm {} ; foreach v $currentp($name) {set cm([lindex [split $v .] 0]) $v}
248
249 set all [lsort -dict [struct::set union [array names om] [array names cm]]]
250
251 sakdebug {
252 puts @@@@@@@@@@@@@@@@
253 parray om
254 parray cm
255 puts all\ $all
256 puts @@@@@@@@@@@@@@@@
257 }
258
259 foreach v $all {
260 if {[info exists om($v)]} {set ov $om($v)} else {set ov ""}
261 if {[info exists cm($v)]} {set cv $cm($v)} else {set cv ""}
262 $mat add row [list $m $name $ov $cv $note]
263 }
264 return
265}
266
267proc ::sak::readme::Clean {m start col} {
268 set n [$m rows]
269 set marks [list $start]
270 set last {}
271 set lastm -1
272 set sq 0
273
274 for {set i $start} {$i < $n} {incr i} {
275 set str [$m get cell $col $i]
276
277 if {$str eq $last} {
278 set sq 1
279 $m set cell $col $i {}
280 if {$lastm >= 0} {
281 #puts stderr "@ $i / <$last> / <$str> / ++ $lastm"
282 lappend marks $lastm
283 set lastm -1
284 } else {
285 #puts stderr "@ $i / <$last> / <$str> /"
286 }
287 } else {
288 set last $str
289 set lastm $i
290 if {$sq} {
291 #puts stderr "@ $i / <$last> / <$str> / ++ $i /saved"
292 lappend marks $i
293 set sq 0
294 } else {
295 #puts stderr "@ $i / <$last> / <$str> / saved"
296 }
297 }
298 }
299 return [lsort -uniq -increasing -integer $marks]
300}
301
302proc ::sak::readme::Sep {m char marks} {
303
304 #puts stderr "$m = $marks"
305
306 set n [$m columns]
307 set sep {}
308 for {set i 0} {$i < $n} {incr i} {
309 lappend sep [string repeat $char [expr {2+[$m columnwidth $i]}]]
310 }
311
312 foreach k [linsert [lsort -decreasing -integer -uniq $marks] 0 end] {
313 $m insert row $k $sep
314 }
315 return
316}
317
318proc ::sak::readme::Indent {pfx text} {
319 return ${pfx}[join [split $text \n] \n$pfx]
320}
321
322proc ::sak::readme::Detrail {text} {
323 set res {}
324 foreach line [split $text \n] {
325 lappend res [string trimright $line]
326 }
327 return [join $res \n]
328}
329
330proc ::sak::readme::Note {m p} {
331 # Look for a note, and present to caller, if any.
332 variable notes
333 #parray notes
334 set k [list $m $p]
335 #puts <$k>
336 if {[info exists notes($k)]} {
337 return [join $notes($k) { }]
338 }
339 return ""
340}
341
342proc ::sak::readme::Provided {m} {
343 set result {}
344 foreach {p ___} [ppackages $m] {
345 lappend result $p
346 }
347 return $result
348}
349
350proc ::sak::readme::LoadNotes {} {
351 global distribution
352 variable notes
353 array set notes {}
354
355 catch {
356 set f [file join $distribution .NOTE]
357 set f [open $f r]
358 while {![eof $f]} {
359 if {[gets $f line] < 0} continue
360 set line [string trim $line]
361 if {$line == {}} continue
362 foreach {k t} $line break
363 set notes($k) $t
364 }
365 close $f
366 } msg
367 return
368}
369
370proc ::sak::readme::loadoldv {fname} {
371 set f [open $fname r]
372 foreach line [split [read $f] \n] {
373 set line [string trim $line]
374 if {[string match @* $line]} {
375 foreach {__ __ v} $line break
376 close $f
377 return $v
378 }
379 }
380 close $f
381 return -code error {Version not found}
382}
383
384##
385# ###
386
387namespace eval ::sak::readme {
388 variable legend {
389Legend Change Details Comments
390 ------ ------- ---------
391 Major API: ** incompatible ** API changes.
392
393 Minor EF : Extended functionality, API.
394 I : Major rewrite, but no API change
395
396 Patch B : Bug fixes.
397 EX : New examples.
398 P : Performance enhancement.
399
400 None T : Testsuite changes.
401 D : Documentation updates.
402 }
403}
404
405package provide sak::readme 1.0
406