source: admin_finroc_debian/new_version @ 14:53adc9bb587d

14.08 tip
Last change on this file since 14:53adc9bb587d was 14:53adc9bb587d, checked in by Tobias Föhst <foehst@…>, 18 months ago

Fixes warning in maintainer-lookup
  • Property exe set to *
File size: 13.4 KB
Line 
1#!/usr/bin/perl -w
2
3use strict;
4
5use Env '$FINROC_HOME';
6
7use Encode;
8$FINROC_HOME = decode_utf8 $FINROC_HOME;
9
10use lib "$FINROC_HOME/scripts/perl";
11use FINROC::messages;
12use FINROC::getopt;
13use FINROC::sources;
14use FINROC::scm;
15use FINROC::components;
16use FINROC::utilities;
17
18use open qw(:std :utf8);
19
20use POSIX 'strftime';
21use File::Copy;
22use File::Basename;
23
24use Cwd;
25use Cwd 'abs_path';
26
27
28
29my $source_stats_file = "debian/source/status";
30my $changelog_file = "debian/changelog";
31my $news_file = "debian/NEWS.Debian";
32
33
34
35############################
36##  Command line options  ##
37############################
38
39SetHelp undef, {}, undef;
40
41ParseCommandLine [], undef;
42
43
44
45##############################################
46INFOMSG "Gathering maintainer information.\n";
47##############################################
48
49use Env qw($DEBFULLNAME $NAME $DEBEMAIL $EMAIL);
50$DEBFULLNAME = decode_utf8 $DEBFULLNAME;
51$NAME = decode_utf8 $NAME;
52$DEBEMAIL = decode_utf8 $DEBEMAIL;
53$EMAIL = decode_utf8 $EMAIL;
54
55if ($DEBEMAIL && $DEBEMAIL =~ /^(.*)\s+<(.*)>$/)
56{
57    $DEBFULLNAME = $1 unless $DEBFULLNAME;
58    $DEBEMAIL = $2;
59}
60unless ($DEBEMAIL && $DEBFULLNAME)
61{
62    if ($EMAIL && $EMAIL =~ /^(.*)\s+<(.*)>$/)
63    {
64        $DEBFULLNAME = $1 unless $DEBFULLNAME;
65        $EMAIL = $2;
66    }
67}
68
69sub GetNameFromOS()
70{
71    my @data = getpwuid $<;
72    (my $name = decode_utf8 $data[6]) =~ s/,.*// if $data[6];
73    return $name;
74}
75sub GetEmailFromOS()
76{
77    my $host;
78    if (open MAILNAME, "/etc/mailname")
79    {
80        chomp($host = <MAILNAME>);
81        close MAILNAME;
82    }
83    chomp($host = `hostname --fqdn 2> /dev/null`) unless $host;
84    return sprintf "%s\@$host", ${[getpwuid $<]}[0];
85}
86my $maintainer = $DEBFULLNAME || $NAME || GetNameFromOS;
87my $email = $DEBEMAIL || $EMAIL || GetEmailFromOS;
88
89my $date = strftime "%a, %d %b %Y %H:%M:%S %z", localtime;
90
91
92
93#######################################
94INFOMSG "Reading old source status.\n";
95#######################################
96
97my %source_stats;
98if (-f $source_stats_file)
99{
100    open SOURCE_STATS, "<$source_stats_file" or die "Could not open $source_stats_file: $!\n";
101    while (<SOURCE_STATS>)
102    {
103        chomp;
104        my ($label, $id) = split "\t";
105        $source_stats{$label} = { id => $id,
106                                  component => GetComponentNameFromDirectory(abs_path join "/", ($FINROC_HOME, $label)),
107                                  state => 'removed'};
108    }
109    close SOURCE_STATS;
110}
111${$source_stats{'.'}}{component} = "finroc";
112
113
114
115##########################################
116INFOMSG "Collecting new source status.\n";
117##########################################
118
119sub Identify($$)
120{
121    my ($directory, $scm) = @_;
122
123    if ($scm eq "hg")
124    {
125        chomp(my $id = `hg --cwd '$directory' id --id`);
126        $id =~ s/\+$//;
127        return $id;
128    }
129    die "unsupported scm\n";
130}
131
132sub Timestamp($$)
133{
134    my ($directory, $scm) = @_;
135
136    if ($scm eq "hg")
137    {
138        chomp(my $timestamp = `perl -e "print \$(hg --cwd '$directory' log -r. --template '{date}')"`);
139        return strftime "%Y%m%d%H%M%S", localtime $timestamp;
140    }
141    die "unsupported scm\n";
142}
143
144sub Branch($$)
145{
146    my ($directory, $scm) = @_;
147
148    return "unstable" if IsOnDefaultBranch $directory;
149    if ($scm eq "hg")
150    {
151        chomp(my $branch = `hg --cwd '$directory' branch`);
152     
153        return $branch;
154    }
155    die "unsupported scm\n";
156}
157
158sub CollectAuthors($$)
159{
160    my ($directory, $scm) = @_;
161
162    if ($scm eq "hg")
163    {
164        my $command = sprintf "hg --cwd '%s' log --template '{author|person}\n' -r::. | sort | uniq", $directory;
165        DEBUGMSG sprintf "Executing '%s'\n", $command;
166        chomp(my @authors = `$command`);
167        ERRORMSG "Command failed!\n" if $?;
168        return \@authors;
169    }
170    die "unsupported scm\n";
171}
172
173sub CollectChanges($$$)
174{
175    my ($directory, $scm, $old_rev) = @_;
176
177    if ($scm eq "hg")
178    {
179        $old_rev = "" unless $old_rev;
180        my $command = sprintf "hg --cwd '%s' log --template '{rev}\n' -r'ancestors(.) and not ancestors(%s) and not merge()'", $directory, $old_rev;
181        DEBUGMSG sprintf "Executing '%s'\n", $command;
182        chomp(my @revs = `$command`);
183        ERRORMSG "Command failed!\n" if $?;
184        my %changes;
185        foreach my $rev (@revs)
186        {
187            my $command = sprintf "hg --cwd '%s' log --template '{author|person}\n' -r'%s'", $directory, $rev;
188            DEBUGMSG sprintf "Executing '%s'\n", $command;
189            chomp(my $author = `$command`);
190            ERRORMSG "Command failed!\n" if $?;
191            $changes{$author} = [] unless $changes{$author};
192            $command = sprintf "hg --cwd '%s' log --template '{desc}\n' -r'%s'", $directory, $rev;
193            DEBUGMSG sprintf "Executing '%s'\n", $command;
194            chomp(my $change = `$command`);
195            ERRORMSG "Command failed!\n" if $?;
196            push @{$changes{$author}}, $change;
197        }
198        return \%changes;
199    }
200    die "unsupported scm\n";
201}
202
203sub max($$) { $_[$_[0] < $_[1]] }
204
205my $latest_timestamp = 0;
206my %branches;
207my $uncommitted_modifications_found = 0;
208
209my (@added, @modified, @removed);
210
211my %directories = FindWorkingCopyBaseFolders;
212my ($processed, $total) = (0, scalar keys %directories);
213my $progress = "";
214$| = 1;
215foreach my $directory (sort keys %directories)
216{
217    print "\b" x length $progress;
218    $progress = sprintf "%d/%d", ++$processed, $total;
219    print $progress;
220
221    (my $label = $directory) =~ s/^\Q$FINROC_HOME\E/./;
222
223    my $scm = FINROC::scm::GetSCMNameFromWorkingCopy $directory;
224    my $uncommitted_modifications = Status $directory, 1, 0, undef, undef;
225    $uncommitted_modifications_found = 1 if $uncommitted_modifications;
226    $branches{Branch $directory, $scm} = 1 unless $label eq "./make_builder";
227    $latest_timestamp = max $latest_timestamp, Timestamp $directory, $scm;
228
229    unless ($source_stats{$label})
230    {
231        $source_stats{$label} = { id => Identify($directory, $scm),
232                                  component => GetComponentNameFromDirectory($directory),
233                                  authors => CollectAuthors($directory, $scm),
234                                  state => 'added' };
235        push @added, $label;
236        next;
237    }
238    my $old_id = $source_stats{$label}{id};
239    $source_stats{$label}{id} = Identify $directory, $scm;
240    $source_stats{$label}{state} = 'seen';
241    next unless $source_stats{$label}{id} ne $old_id || $uncommitted_modifications;
242
243    $source_stats{$label}{changes} = CollectChanges $directory, $scm, $old_id;
244    if ($uncommitted_modifications)
245    {
246        $source_stats{$label}{changes} = {} unless $source_stats{$label}{changes};
247        $source_stats{$label}{changes}{$maintainer} = [] unless $source_stats{$label}{changes}{$maintainer};
248        push @{$source_stats{$label}{changes}{$maintainer}}, sprintf "\n### Describe uncommitted modifications (and delete this block): ###\n%s\n### end of modifications ###", join "\n", map { sprintf "## %s", $_ } split "\n", $uncommitted_modifications;
249    }
250    push @modified, $label;
251}
252print "\b" x length $progress;
253@removed = grep $source_stats{$_}{state} eq 'removed', keys %source_stats;
254
255
256
257#############################################
258INFOMSG "Determining new package version.\n";
259#############################################
260
261chomp(my $source = `dpkg-parsechangelog -Ssource`);
262chomp(my $version = `dpkg-parsechangelog -Sversion`);
263my (undef, $epoch, $uversion, $dversion) = ($version =~ /^((\d+):)?(.+?)-([^-]+)$/);
264$dversion =~ s/[^\w\.].*$//;
265
266(my $new_dversion = $dversion) =~ s/[\d\.]+(?=\w+\d)/0/g;
267$new_dversion =~ s/[\d\.]+$/1/;
268
269my ($release, $timestamp) = ($uversion =~ /^([\d\.]+)\+(.*)$/);
270my $new_release = Branch ".", FINROC::scm::GetSCMNameFromWorkingCopy ".";
271if (scalar keys %branches > 1)
272{
273    WARNMSG("More than one branches active!\n".
274            "I will use the release information of the base folder ($new_release), but note the mixed state and check if this really is what you want.\n");
275    INFOMSG "Do you want to continue? [Y/n] ";
276    if (<STDIN> =~ /^n/)
277    {
278        INFOMSG "Abort.\n";
279        exit 1;
280    }
281}
282
283my $new_timestamp = $latest_timestamp;
284if ($uncommitted_modifications_found)
285{
286    WARNMSG("The source tree contains uncommitted modifications!\n".
287            "This is not necessarily a problem, but might lead to ambiguous package versions by using the current timestamp (not represented in scm).\n");
288    INFOMSG "Do you want to continue? [Y/n] ";
289    if (<STDIN> =~ /^n/)
290    {
291        INFOMSG "Abort.\n";
292        exit 1;
293    }
294    $new_timestamp = eval { strftime "%Y%m%d%H%M%S", gmtime};
295}
296
297my $new_uversion = join "+", ($new_release, $new_timestamp);
298my $new_version = join "-", ($new_uversion, $new_dversion);
299$new_version = join ":", ($epoch, $new_version) if $epoch;
300
301my $command = sprintf "dpkg --compare-versions %s lt %s", $version, $new_version;
302DEBUGMSG sprintf "Executing '%s'\n", $command;
303if (system $command)
304{
305    ERRORMSG "New version is not greater than the old one!\n" unless @added || @removed;
306
307    WARNMSG sprintf("The version determined from release and scm timestamps is not greater than the old one!\n".
308                    "Workaround: increasing the old version as components were added or removed. Note that this might lead to ambiguous package versions.\n");
309    INFOMSG "Do you want to continue? [Y/n] ";
310    if (<STDIN> =~ /^n/)
311    {
312        INFOMSG "Abort.\n";
313        exit 1;
314    }
315
316    ($timestamp, my $offset) = split /\+/, $timestamp;
317    $offset++;
318
319    $new_uversion = join "+", ($new_release, $new_timestamp, $offset);
320    $new_version = join "-", ($new_uversion, $new_dversion);
321    $new_version = join ":", ($epoch, $new_version) if $epoch;
322}
323
324if ($new_release ne $release)
325{
326    $source = sprintf "finroc-%s", $new_release;
327}
328
329
330
331########################################
332INFOMSG "Writing changelog and news.\n";
333########################################
334
335my $changelog = sprintf "%s (%s) UNRELEASED; urgency=low\n\n", $source, $new_version;
336$changelog .= "### This entry was generated from SCM log. Therefore, it is most likely too elaborate.\n";
337$changelog .= "### Please review and change it according to\n";
338$changelog .= "### https://www.debian.org/doc/manuals/developers-reference/best-pkging-practices.html#bpp-debian-changelog\n";
339$changelog .= "### Also, delete this block.\n";
340if (@modified)
341{
342    $changelog .= "  * Upstream modifications\n";
343    foreach my $entry (sort { $$a{component} cmp $$b{component} } @source_stats{@modified})
344    {
345        $changelog .= sprintf "\n    == %s ==%s\n", $$entry{component}, join "\n", map { sprintf "\n      [%s]\n%s", $_, join "\n", map { my @lines = split "\n"; join "\n", map { s/^/      /; $_ } @lines; } @{$$entry{changes}{$_}} } sort keys %{$$entry{changes}};
346    }
347    $changelog .= "\n";
348}
349if (@added)
350{
351    $changelog .= "  * Added components\n";
352    foreach my $entry (sort { $$a{component} cmp $$b{component} } @source_stats{@added})
353    {
354        $changelog .= sprintf "    %s\n      (involved authors: %s)\n", $$entry{component}, join ", ", sort @{$$entry{authors}};
355    }
356    $changelog .= "\n";
357}
358if (@removed)
359{
360    $changelog .= "  * Removed\n";
361    foreach my $entry (sort { $$a{component} cmp $$b{component} } @source_stats{@removed})
362    {
363        $changelog .= sprintf "    - %s\n", $$entry{component};
364    }
365    $changelog .= "\n";
366}
367$changelog .= sprintf " -- %s <%s>  %s\n\n", $maintainer, $email, $date;
368
369my $modification_required = 1;
370sub UpdateLogFile($$)
371{
372    my ($file, $log) = @_;
373
374    if (-f $file)
375    {
376        local $/ = undef;
377        open LOG_FILE, "<$file" or die "Could not open $file: $!\n";
378        $log .= <LOG_FILE>;
379        close LOG_FILE;
380    }
381
382    open LOG_FILE, ">$file.tmp" or die "Could not open $file.tmp: $!\n";
383    print LOG_FILE $log;
384    close LOG_FILE;
385
386    my $mtime = (stat "$file.tmp")[9];
387    $mtime--;
388    utime $mtime, $mtime, "$file.tmp";
389
390    system sprintf "sensible-editor +0:%d $file.tmp", 5 + length $source.$new_version;
391    ERRORMSG sprintf "Error editing %s!\n", $file if $?;
392
393    my $new_mtime = (stat "$file.tmp")[9];
394    ERRORMSG sprintf "%s unmodified!\n", $file if $modification_required && $new_mtime == $mtime;
395
396    copy "$file.tmp", $file or ERRORMSG sprintf "Could not replace %s with new version!\n", $file;
397    map { unlink } ( "$file.tmp", "$file.tmp~");
398}
399
400if ($new_release ne $release)
401{
402    UpdateLogFile $news_file, $changelog;
403
404    open NEWS, "<$news_file" or die "Could not open $news_file: $!\n";
405    $changelog = <NEWS>;
406    close NEWS;
407
408    $changelog .= "\n";
409    $changelog .= sprintf "  * New upstream release: %s\n", $new_release;
410    $changelog .= sprintf "    (see %s for more detailed information)\n\n", basename $news_file;
411    $changelog .= sprintf " -- %s <%s>  %s\n\n", $maintainer, $email, $date;
412    $modification_required = 0;
413}
414
415UpdateLogFile $changelog_file, $changelog;
416
417if ($new_release ne $release)
418{
419    chomp(my $news_head = `head -n1 $news_file`);
420    chomp(my $changelog_head = `head -n1 $changelog_file`);
421    ERRORMSG sprintf "%s and %s do not match!\n", $news_file, $changelog_file if $news_head ne $changelog_head;
422}
423chomp($source = `dpkg-parsechangelog -Ssource`);
424chomp($new_version = `dpkg-parsechangelog -Sversion`);
425(undef, undef, $new_uversion, undef) = ($new_version =~ /^((\d+):)?(.+?)-([^-]+)$/);
426
427
428
429#########################################
430INFOMSG "Creating new source archive.\n";
431#########################################
432
433my $source_archive = sprintf "../%s_%s.orig.tar.gz", $source, $new_uversion;
434ERRORMSG sprintf "Archive %s already exists!\n", $source_archive if -f $source_archive;
435$command = sprintf "dh clean && tar -czf %s --exclude debian --transform 's,^\./,finroc/,' .", $source_archive;
436DEBUGMSG sprintf "Executing '%s'\n", $command;
437system $command;
438ERRORMSG "Command failed!\n" if $?;
439
440
441
442#######################################
443INFOMSG "Writing new source status.\n";
444#######################################
445
446open SOURCE_STATS, ">$source_stats_file" or die "Could not open $source_stats_file: $!\n";
447map { printf SOURCE_STATS "%s\t%s\n", $_, $source_stats{$_}{id} } sort keys %source_stats;
448close SOURCE_STATS;
449
450
451
452##################
453INFOMSG "Done.\n";
454##################
Note: See TracBrowser for help on using the repository browser.