gnucommit

   1 #!/usr/bin/perl
   2
   3 =head1 NAME
   4
   5 gnucommit - commit changes to packages with GNU-format ChangeLog files
   6
   7 =head1 SYNOPSIS
   8
   9 B<gnucommit> [B<--release>] [B<--message=>I<text>] [B<--noact>] [B<--confirm>] [B<--changelog=>I<path>] [B<--all> | I<files to commit>]
  10
  11 =head1 DESCRIPTION
  12
  13 B<gnucommit> generates a commit message based on new text in B<ChangeLog>,
  14 and commits the change to the repository. It must be run in a working
  15 copy for the package. Supported version control systems are:
  16 B<svn> (subversion), B<bzr>.
  17
  18 =head1 OPTIONS
  19
  20 =over 4
  21
  22 =item B<-c> B<--changelog> I<path>
  23
  24 Specify an alternate location for the changelog. By default ChangeLog is
  25 used.
  26
  27 =item B<-r> B<--release>
  28
  29 Commit a release of the package. The version number is determined from
  30 ChangeLog, and is used to tag the package in the repository.
  31
  32 Note that svn/svk tagging conventions vary, so gnucommit uses
  33 L<svnpath(1)> to determine where the tag should be placed in the
  34 repository.
  35
  36 =item B<-m> I<text> B<--message> I<text>
  37
  38 Specify a commit message to use. Useful if the program cannot determine
  39 a commit message on its own based on ChangeLog, or if you want to
  40 override the default message.
  41
  42 =item B<-n> B<--noact>
  43
  44 Do not actually do anything, but do print the commands that would be run.
  45
  46 =item B<-C> B<--confirm>
  47
  48 Display the generated commit message and ask for confirmation before committing
  49 it.
  50
  51 =item B<-a> B<--all>
  52
  53 Commit all files. This is the default operation when using a VCS other
  54 than git.
  55
  56 =item I<files to commit>
  57
  58 Specify which files to commit (ChangeLog is added to the list
  59 automatically.)
  60
  61 =item B<-s> B<--strip-message>, B<--no-strip-message>
  62
  63 If this option is set and the commit message has been derived from the
  64 changelog, the characters "* " will be stripped from the beginning of
  65 the message.
  66
  67 This option is ignored if more than one line of the message
  68 begins with "* ".
  69
  70 =item B<--sign-tags>, B<--no-sign-tags>
  71
  72 If this option is set, then tags that gnucommit creates will be signed
  73 using gnupg. Currently this is only supported by git.
  74
  75 =over 4
  76
  77 =back
  78
  79 =head1 CONFIGURATION VARIABLES
  80
  81 The two configuration files F</etc/devscripts.conf> and
  82 F<~/.devscripts> are sourced by a shell in that order to set
  83 configuration variables.  Command line options can be used to override
  84 configuration file settings.  Environment variable settings are
  85 ignored for this purpose.  The currently recognised variables are:
  86
  87 =over 4
  88
  89 =item B<DEBCOMMIT_STRIP_MESSAGE>
  90
  91 If this is set to I<yes>, then it is the same as the --strip-message
  92 command line parameter being used. The default is I<no>.
  93
  94 =item B<DEBCOMMIT_SIGN_TAGS>
  95
  96 If this is set to I<yes>, then it is the same as the --sign-tags command
  97 line parameter being used. The default is I<no>.
  98
  99 =item B<DEBSIGN_KEYID>
 100
 101 This is the key id used for signing tags. If not set, a default will be
 102 chosen by the revision control system.
 103
 104 =cut
 105
 106 use warnings;
 107 use strict;
 108 use Getopt::Long;
 109 use Cwd;
 110 use File::Basename;
 111 my $progname = basename($0);
 112
 113 my $modified_conf_msg;
 114
 115 sub usage {
 116     print <<"EOT";
 117 Usage: $progname [options] [files to commit]
 118        $progname --version
 119        $progname --help
 120
 121 Generates a commit message based on new text in ChangeLog,
 122 and commit the change to a package\'s repository.
 123
 124 Options:
 125    -c --changelog=path Specify the location of the changelog
 126    -r --release        Commit a release of the package and create a tag
 127    -m --message=text   Specify a commit message
 128    -n --noact          Dry run, no actual commits
 129    -C --confirm        Ask for confirmation of the message before commit
 130    -a --all            Commit all files (default except for git)
 131    -s --strip-message  Strip the leading '* ' from the commit message
 132    --no-strip-message  Do not strip a leading '* ' (default)
 133    --sign-tags         Enable signing of tags (git only)
 134    --no-sign-tags      Do not sign tags (default)
 135    -h --help           This message
 136    -v --version        Version information
 137
 138    --no-conf, --noconf
 139                    Don\'t read devscripts config files;
 140                    must be the first option given
 141
 142 Default settings modified by devscripts configuration files:
 143 $modified_conf_msg
 144
 145 EOT
 146 }
 147
 148 sub version {
 149     print <<"EOF";
 150 This is $progname, from the Debian devscripts package, version 2.10.11
 151 This code is copyright by Joey Hess <joeyh\@debian.org>, all rights reserved.
 152 This program comes with ABSOLUTELY NO WARRANTY.
 153 You are free to redistribute this code under the terms of the
 154 GNU General Public License, version 2 or later.
 155 EOF
 156 }
 157
 158 my $release=0;
 159 my $message;
 160 my $noact=0;
 161 my $confirm=0;
 162 my $all=0;
 163 my $stripmessage=0;
 164 my $signtags=0;
 165 my $changelog="ChangeLog";
 166 my $keyid;
 167
 168 # Now start by reading configuration files and then command line
 169 # The next stuff is boilerplate
 170
 171 if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
 172     $modified_conf_msg = "  (no configuration files read)";
 173     shift;
 174 } else {
 175     my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
 176     my %config_vars = (
 177                        'DEBCOMMIT_STRIP_MESSAGE' => 'no',
 178                        'DEBCOMMIT_SIGN_TAGS' => 'no',
 179                        'DEBSIGN_KEYID' => '',
 180                       );
 181     my %config_default = %config_vars;
 182
 183     my $shell_cmd;
 184     # Set defaults
 185     foreach my $var (keys %config_vars) {
 186         $shell_cmd .= qq[$var="$config_vars{$var}";\n];
 187     }
 188     $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
 189     $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
 190     # Read back values
 191     foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
 192     my $shell_out = `/bin/bash -c '$shell_cmd'`;
 193     @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
 194
 195     # Check validity
 196     $config_vars{'DEBCOMMIT_STRIP_MESSAGE'} =~ /^(yes|no)$/
 197         or $config_vars{'DEBCOMMIT_STRIP_MESSAGE'}='no';
 198     $config_vars{'DEBCOMMIT_SIGN_TAGS'} =~ /^(yes|no)$/
 199         or $config_vars{'DEBCOMMIT_SIGN_TAGS'}='no';
 200
 201     foreach my $var (sort keys %config_vars) {
 202         if ($config_vars{$var} ne $config_default{$var}) {
 203             $modified_conf_msg .= "  $var=$config_vars{$var}\n";
 204         }
 205     }
 206     $modified_conf_msg ||= "  (none)\n";
 207     chomp $modified_conf_msg;
 208
 209     $stripmessage = $config_vars{'DEBCOMMIT_STRIP_MESSAGE'} eq 'no' ? 0 : 1;
 210     $signtags = $config_vars{'DEBCOMMIT_SIGN_TAGS'} eq 'no' ? 0 : 1;
 211     if (exists $config_vars{'DEBSIGN_KEYID'} &&
 212         length $config_vars{'DEBSIGN_KEYID'}) {
 213         $keyid=$config_vars{'DEBSIGN_KEYID'};
 214     }
 215 }
 216
 217 # Now read the command line arguments
 218
 219 Getopt::Long::Configure("bundling");
 220 if (! GetOptions(
 221                  "r|release" => \$release,
 222                  "m|message=s" => \$message,
 223                  "n|noact" => \$noact,
 224                  "C|confirm" => \$confirm,
 225                  "a|all" => \$all,
 226                  "c|changelog=s" => \$changelog,
 227                  "s|strip-message!" => \$stripmessage,
 228                  "sign-tags!" => \$signtags,
 229                  "h|help" => sub { usage(); exit 0; },
 230                  "v|version" => sub { version(); exit 0; },
 231                  )) {
 232     die "Usage: gnucommit [--release] [--message=text] [--noact] [--confirm] [--changelog=path] [--all | files to commit]\n";
 233 }
 234
 235 my @files_to_commit = @ARGV;
 236 if (@files_to_commit && !grep(/$changelog/,@files_to_commit)) {
 237     push @files_to_commit, $changelog;
 238 }
 239
 240 my $prog=getprog();
 241 if (! -e $changelog) {
 242     die "gnucommit: cannot find $changelog\n";
 243 }
 244
 245 if ($release) {
 246     open (C, "<$changelog" ) || die "gnucommit: cannot read $changelog: $!";
 247     <C>; <C>;
 248     my $firstline=<C>;
 249     if ($firstline!~/Version: ([0-9][a-z0-9.-]*)/) {
 250         die "gnucommit: no Version: changelog entry found\n";
 251     }
 252     close C;
 253
 254     my $version=$1;
 255     $version=~s/\.$//;
 256
 257     #$message="releasing version $version" if ! defined $message;
 258     $message=getmessage() if ! defined $message;
 259     commit($message);
 260     tag($version);
 261 }
 262 else {
 263     $message=getmessage() if ! defined $message;
 264     commit($message) if not $confirm or confirm($message);
 265 }
 266
 267 sub getprog {
 268     if (-d ".svn") {
 269         return "svn";
 270     }
 271     if (-d "CVS") {
 272         return "cvs";
 273     }
 274     if (-d "{arch}") {
 275         # I don't think we can tell just from the working copy
 276         # whether to use tla or baz, so try baz if it's available,
 277         # otherwise fall back to tla.
 278         if (system ("baz --version >/dev/null 2>&1") == 0) {
 279             return "baz";
 280         } else {
 281             return "tla";
 282         }
 283     }
 284     if (-d ".bzr") {
 285         return "bzr";
 286     }
 287     if (-d ".git") {
 288         return "git";
 289     }
 290     if (-d ".hg") {
 291         return "hg";
 292     }
 293
 294     # Test for this file to avoid interactive prompting from svk.
 295     if (-d "$ENV{HOME}/.svk/local") {
 296         # svk has no useful directories so try to run it.
 297         my $svkpath=`svk info . 2>/dev/null| grep -i '^Depot Path:' | cut -d ' ' -f 3`;
 298         if (length $svkpath) {
 299             return "svk";
 300         }
 301     }
 302
 303     # .git may be in a parent directory, rather than the current
 304     # directory, if multiple packages are kept in one git repository.
 305     my $dir=getcwd();
 306     while ($dir=~s/[^\/]*\/?$// && length $dir) {
 307         if (-d "$dir/.git") {
 308                 return "git";
 309         }
 310     }
 311
 312     die "gnucommit: not in a cvs, subversion, baz, bzr, git, hg, or svk working copy\n";
 313 }
 314
 315 sub action {
 316     my $prog=shift;
 317     print $prog, " ",
 318       join(" ", map { if (/[^-A-Za-z0-9]/) { s/'/'\\''/g; "'$_'" } else { $_ } } @_), "\n";
 319     return 1 if $noact;
 320     return (system($prog, @_) != 0) ? 0 : 1;
 321 }
 322
 323 sub commit {
 324     my $message=shift;
 325
 326     die "gnucommit: can't specify a list of files to commit when using --all\n"
 327         if (@files_to_commit and $all);
 328
 329     if ($prog =~ /^(cvs|svn|svk|bzr|hg)$/) {
 330         my $author = getauthor();
 331         my @author;
 332         if ($prog eq 'bzr' and defined $author) {
 333             @author = ('--author', $author);
 334         }
 335         if (! action($prog, "commit", @author, "-m", $message, @files_to_commit)) {
 336             die "gnucommit: commit failed\n";
 337         }
 338     }
 339     elsif ($prog eq 'git') {
 340         if (! @files_to_commit && $all) {
 341             # check to see if the WC is clean. git-commit would exit
 342             # nonzero, so don't run it.
 343             my $status=`LANG=C git status`;
 344             if ($status=~/nothing to commit \(working directory clean\)/) {
 345                     print $status;
 346                     return;
 347             }
 348         }
 349         if ($all) {
 350             @files_to_commit=("-a")
 351         }
 352         if (! action($prog, "commit", "-m", $message, @files_to_commit)) {
 353             die "gnucommit: commit failed\n";
 354         }
 355     }
 356     elsif ($prog eq 'tla' || $prog eq 'baz') {
 357         my $summary=$message;
 358         $summary=~s/^((?:\* )?[^\n]{1,72})(?:(?:\s|\n).*|$)/$1/ms;
 359         my @args;
 360         if ($summary eq $message) {
 361             $summary=~s/^\* //s;
 362             @args=("-s", $summary);
 363         } else {
 364             $summary=~s/^\* //s;
 365             @args=("-s", "$summary ...", "-L", $message);
 366         }
 367         push(
 368             @args,
 369             (($prog eq 'tla') ? '--' : ()),
 370             @files_to_commit,
 371         ) if @files_to_commit;
 372
 373         if (! action($prog, "commit", @args)) {
 374             die "gnucommit: commit failed\n";
 375         }
 376     }
 377     else {
 378         die "gnucommit: unknown program $prog";
 379     }
 380 }
 381
 382 sub tag {
 383     my $tag=shift;
 384
 385     if ($prog eq 'svn' || $prog eq 'svk') {
 386         my $svnpath=`svnpath`;
 387         chomp $svnpath;
 388         my $tagpath=`svnpath tags`;
 389         chomp $tagpath;
 390
 391         if (! action($prog, "copy", $svnpath, "$tagpath/$tag",
 392                      "-m", "tagging version $tag")) {
 393             if (! action($prog, "mkdir", $tagpath,
 394                          "-m", "create tag directory") ||
 395                 ! action($prog, "copy", $svnpath, "$tagpath/$tag",
 396                          "-m", "tagging version $tag")) {
 397                 die "gnucommit: failed tagging with $tag\n";
 398             }
 399         }
 400     }
 401     elsif ($prog eq 'cvs') {
 402         $tag=~s/^[0-9]+://; # strip epoch
 403         $tag=~tr/./_/;      # mangle for cvs
 404         $tag="debian_version_$tag";
 405         if (! action("cvs", "tag", "-f", $tag)) {
 406             die "gnucommit: failed tagging with $tag\n";
 407         }
 408     }
 409     elsif ($prog eq 'tla' || $prog eq 'baz') {
 410         my $archpath=`archpath`;
 411         chomp $archpath;
 412         my $tagpath=`archpath releases--\Q$tag\E`;
 413         chomp $tagpath;
 414         my $subcommand;
 415         if ($prog eq 'baz') {
 416             $subcommand="branch";
 417         } else {
 418             $subcommand="tag";
 419         }
 420
 421         if (! action($prog, $subcommand, $archpath, $tagpath)) {
 422             die "gnucommit: failed tagging with $tag\n";
 423         }
 424     }
 425     elsif ($prog eq 'bzr') {
 426         if (action("$prog tags >/dev/null 2>&1")) {
 427             if (! action($prog, "tag", $tag)) {
 428                 die "gnucommit: failed tagging with $tag\n";
 429             }
 430         } else {
 431                 die "gnucommit: bazaar or branch version too old to support tags\n";
 432         }
 433     }
 434     elsif ($prog eq 'git') {
 435         $tag=~s/^[0-9]+://; # strip epoch
 436         if ($tag=~/-/) {
 437                 # not a native package, so tag as a debian release
 438                 $tag="debian/$tag";
 439         }
 440
 441         if ($signtags) {
 442                 if (defined $keyid) {
 443                         if (! action($prog, "tag", "-u", $keyid, "-m",
 444                                      "tagging version $tag", $tag)) {
 445                                 die "gnucommit: failed tagging with $tag\n";
 446                         }
 447                 }
 448                 else {
 449                         if (! action($prog, "tag", "-s", "-m",
 450                                      "tagging version $tag", $tag)) {
 451                                 die "gnucommit: failed tagging with $tag\n";
 452                         }
 453                 }
 454         }
 455         elsif (! action($prog, "tag", $tag)) {
 456                 die "gnucommit: failed tagging with $tag\n";
 457         }
 458     }
 459     elsif ($prog eq 'hg') {
 460             $tag="debian-$tag";
 461         if (! action($prog, "tag", "-m", "tagging version $tag", $tag)) {
 462                 die "gnucommit: failed tagging with $tag\n";
 463         }
 464     }
 465     else {
 466         die "gnucommit: unknown program $prog";
 467     }
 468 }
 469
 470 sub getauthor {
 471     my $ret;
 472
 473     if ($prog =~ /^(cvs|svn|svk|tla|baz|bzr|git|hg)$/) {
 474         $ret='';
 475         my @diffcmd;
 476
 477         if ($prog eq 'tla' || $prog eq 'baz') {
 478             @diffcmd = ($prog, 'file-diff');
 479         } elsif ($prog eq 'git') {
 480             if ($all) {
 481                 @diffcmd = ('git-diff');
 482             } else {
 483                 @diffcmd = ('git-diff', '--cached');
 484             }
 485         } else {
 486             @diffcmd = ($prog, 'diff');
 487         }
 488
 489         open CHLOG, '-|', @diffcmd, $changelog
 490             or die "gnucommit: cannot run $diffcmd[0]: $!\n";
 491
 492         foreach (<CHLOG>) {
 493             next unless /^\+[0-9]/;
 494             s/^\+//;
 495             chomp;
 496             s/^.*  //; # date
 497             s/  / /g;
 498             if (/^Colin Watson /) {
 499                 last;
 500             } else {
 501                 $ret = $_;
 502                 last;
 503             }
 504         }
 505
 506         close CHLOG;
 507     }
 508     else {
 509         die "gnucommit: unknown program $prog";
 510     }
 511
 512     return $ret;
 513 }
 514
 515 sub getmessage {
 516     my $ret;
 517
 518     if ($prog =~ /^(cvs|svn|svk|tla|baz|bzr|git|hg)$/) {
 519         $ret='';
 520         my @diffcmd;
 521
 522         if ($prog eq 'tla' || $prog eq 'baz') {
 523             @diffcmd = ($prog, 'file-diff');
 524         } elsif ($prog eq 'git') {
 525             if ($all) {
 526                 @diffcmd = ('git-diff');
 527             } else {
 528                 @diffcmd = ('git-diff', '--cached');
 529             }
 530         } else {
 531             @diffcmd = ($prog, 'diff');
 532         }
 533
 534         open CHLOG, '-|', @diffcmd, $changelog
 535             or die "gnucommit: cannot run $diffcmd[0]: $!\n";
 536
 537         # TODO should keep intermediate whitespace in message
 538         foreach (<CHLOG>) {
 539             next unless /^\+\t/;
 540             s/^\+\t//;
 541             $ret .= $_;
 542         }
 543
 544         if (! length $ret) {
 545             my $info='';
 546             if ($prog eq 'git') {
 547                 $info = ' (do you mean "gnucommit -a" or did you forget to run "git add"?)';
 548             }
 549             die "gnucommit: unable to determine commit message using $prog$info\nTry using the -m flag.\n";
 550         } else {
 551             if ($stripmessage) {
 552                 my $count = () = $ret =~ /^\* /mg;
 553                 if ($count == 1) {
 554                     $ret =~ s/^\* //;
 555                 }
 556             }
 557         }
 558     }
 559     else {
 560         die "gnucommit: unknown program $prog";
 561     }
 562
 563     chomp $ret;
 564     return $ret;
 565 }
 566
 567 sub confirm {
 568     my $message=shift;
 569     print $message, "\n--\n";
 570     while(1) {
 571         print "OK to commit? [Y/n] ";
 572         $_ = <STDIN>;
 573         return 0 if /^n/i;
 574         return 1 if /^(y|$)/i;
 575     }
 576 }
 577
 578 =head1 LICENSE
 579
 580 This code is copyright by Joey Hess <joeyh@debian.org>, all rights reserved.
 581 This program comes with ABSOLUTELY NO WARRANTY.
 582 You are free to redistribute this code under the terms of the
 583 GNU General Public License, version 2 or later.
 584
 585 =head1 AUTHOR
 586
 587 Joey Hess <joeyh@debian.org>
 588
 589 =head1 SEE ALSO
 590
 591 L<svnpath(1)>.
 592
 593 =cut