tunings-myplc-devel/commit-email.pl

   1 #!/usr/bin/env perl
   2
   3 # ====================================================================
   4 # commit-email.pl: send a commit email for commit REVISION in
   5 # repository REPOS to some email addresses.
   6 #
   7 # For usage, see the usage subroutine or run the script with no
   8 # command line arguments.
   9 #
  10 # $HeadURL: http://svn.collab.net/repos/svn/branches/1.2.x/tools/hook-scripts/commit-email.pl.in $
  11 # $LastChangedDate: 2005-02-22 04:24:08 -0500 (Tue, 22 Feb 2005) $
  12 # $LastChangedBy: maxb $
  13 # $LastChangedRevision: 13107 $
  14 #
  15 # ====================================================================
  16 # Copyright (c) 2000-2004 CollabNet.  All rights reserved.
  17 #
  18 # This software is licensed as described in the file COPYING, which
  19 # you should have received as part of this distribution.  The terms
  20 # are also available at http://subversion.tigris.org/license-1.html.
  21 # If newer versions of this license are posted there, you may use a
  22 # newer version instead, at your option.
  23 #
  24 # This software consists of voluntary contributions made by many
  25 # individuals.  For exact contribution history, see the revision
  26 # history and logs, available at http://subversion.tigris.org/.
  27 # ====================================================================
  28
  29 # Turn on warnings the best way depending on the Perl version.
  30 BEGIN {
  31   if ( $] >= 5.006_000)
  32     { require warnings; import warnings; }
  33   else
  34     { $^W = 1; }
  35 }
  36
  37 use strict;
  38 use Carp;
  39
  40 ######################################################################
  41 # Configuration section.
  42
  43 # Sendmail path.
  44 my $sendmail = "/usr/sbin/sendmail";
  45
  46 # Svnlook path.
  47 my $svnlook = "/usr/bin/svnlook";
  48
  49 # By default, when a file is deleted from the repository, svnlook diff
  50 # prints the entire contents of the file.  If you want to save space
  51 # in the log and email messages by not printing the file, then set
  52 # $no_diff_deleted to 1.
  53 my $no_diff_deleted = 0;
  54 # By default, when a file is added to the repository, svnlook diff
  55 # prints the entire contents of the file.  If you want to save space
  56 # in the log and email messages by not printing the file, then set
  57 # $no_diff_added to 1.
  58 my $no_diff_added = 0;
  59
  60 # End of Configuration section.
  61 ######################################################################
  62
  63 # Since the path to svnlook depends upon the local installation
  64 # preferences, check that the required programs exist to insure that
  65 # the administrator has set up the script properly.
  66 {
  67   my $ok = 1;
  68   foreach my $program ($sendmail, $svnlook)
  69     {
  70       if (-e $program)
  71         {
  72           unless (-x $program)
  73             {
  74               warn "$0: required program `$program' is not executable, ",
  75                    "edit $0.\n";
  76               $ok = 0;
  77             }
  78         }
  79       else
  80         {
  81           warn "$0: required program `$program' does not exist, edit $0.\n";
  82           $ok = 0;
  83         }
  84     }
  85   exit 1 unless $ok;
  86 }
  87
  88
  89 ######################################################################
  90 # Initial setup/command-line handling.
  91
  92 # Each value in this array holds a hash reference which contains the
  93 # associated email information for one project.  Start with an
  94 # implicit rule that matches all paths.
  95 my @project_settings_list = (&new_project);
  96
  97 # Process the command line arguments till there are none left.  The
  98 # first two arguments that are not used by a command line option are
  99 # the repository path and the revision number.
 100 my $repos;
 101 my $rev;
 102
 103 # Use the reference to the first project to populate.
 104 my $current_project = $project_settings_list[0];
 105
 106 # This hash matches the command line option to the hash key in the
 107 # project.  If a key exists but has a false value (''), then the
 108 # command line option is allowed but requires special handling.
 109 my %opt_to_hash_key = ('--from' => 'from_address',
 110                        '-h'     => 'hostname',
 111                        '-l'     => 'log_file',
 112                        '-m'     => '',
 113                        '-r'     => 'reply_to',
 114                        '-s'     => 'subject_prefix');
 115
 116 while (@ARGV)
 117   {
 118     my $arg = shift @ARGV;
 119     if ($arg =~ /^-/)
 120       {
 121         my $hash_key = $opt_to_hash_key{$arg};
 122         unless (defined $hash_key)
 123           {
 124             die "$0: command line option `$arg' is not recognized.\n";
 125           }
 126
 127         unless (@ARGV)
 128           {
 129             die "$0: command line option `$arg' is missing a value.\n";
 130           }
 131         my $value = shift @ARGV;
 132
 133         if ($hash_key)
 134           {
 135             $current_project->{$hash_key} = $value;
 136           }
 137         else
 138           {
 139             # Here handle -m.
 140             unless ($arg eq '-m')
 141               {
 142                 die "$0: internal error: should only handle -m here.\n";
 143               }
 144             $current_project                = &new_project;
 145             $current_project->{match_regex} = $value;
 146             push(@project_settings_list, $current_project);
 147           }
 148       }
 149     elsif ($arg =~ /^-/)
 150       {
 151         die "$0: command line option `$arg' is not recognized.\n";
 152       }
 153     else
 154       {
 155         if (! defined $repos)
 156           {
 157             $repos = $arg;
 158           }
 159         elsif (! defined $rev)
 160           {
 161             $rev = $arg;
 162           }
 163         else
 164           {
 165             push(@{$current_project->{email_addresses}}, $arg);
 166           }
 167       }
 168   }
 169
 170 # If the revision number is undefined, then there were not enough
 171 # command line arguments.
 172 &usage("$0: too few arguments.") unless defined $rev;
 173
 174 # Check the validity of the command line arguments.  Check that the
 175 # revision is an integer greater than 0 and that the repository
 176 # directory exists.
 177 unless ($rev =~ /^\d+/ and $rev > 0)
 178   {
 179     &usage("$0: revision number `$rev' must be an integer > 0.");
 180   }
 181 unless (-e $repos)
 182   {
 183     &usage("$0: repos directory `$repos' does not exist.");
 184   }
 185 unless (-d _)
 186   {
 187     &usage("$0: repos directory `$repos' is not a directory.");
 188   }
 189
 190 # Check that all of the regular expressions can be compiled and
 191 # compile them.
 192 {
 193   my $ok = 1;
 194   for (my $i=0; $i<@project_settings_list; ++$i)
 195     {
 196       my $match_regex = $project_settings_list[$i]->{match_regex};
 197
 198       # To help users that automatically write regular expressions
 199       # that match the root directory using ^/, remove the / character
 200       # because subversion paths, while they start at the root level,
 201       # do not begin with a /.
 202       $match_regex =~ s#^\^/#^#;
 203
 204       my $match_re;
 205       eval { $match_re = qr/$match_regex/ };
 206       if ($@)
 207         {
 208           warn "$0: -m regex #$i `$match_regex' does not compile:\n$@\n";
 209           $ok = 0;
 210           next;
 211         }
 212       $project_settings_list[$i]->{match_re} = $match_re;
 213     }
 214   exit 1 unless $ok;
 215 }
 216
 217 ######################################################################
 218 # Harvest data using svnlook.
 219
 220 # Change into suitable directory so that svnlook diff can create its .svnlook
 221 # directory. This could be removed - it's only for compatibility with
 222 # 1.0.x svnlook - from 1.1.0, svnlook will be sensible about choosing a
 223 # temporary directory all by itself.
 224 my $tmp_dir = ( -d $ENV{'TEMP'} ? $ENV{'TEMP'} : '/tmp' );
 225 chdir($tmp_dir)
 226   or die "$0: cannot chdir `$tmp_dir': $!\n";
 227
 228 # Get the author, date, and log from svnlook.
 229 my @svnlooklines = &read_from_process($svnlook, 'info', $repos, '-r', $rev);
 230 my $author = shift @svnlooklines;
 231 my $date = shift @svnlooklines;
 232 shift @svnlooklines;
 233 my @log = map { "$_\n" } @svnlooklines;
 234
 235 # Figure out what directories have changed using svnlook.
 236 my @dirschanged = &read_from_process($svnlook, 'dirs-changed', $repos,
 237                                      '-r', $rev);
 238
 239 # Lose the trailing slash in the directory names if one exists, except
 240 # in the case of '/'.
 241 my $rootchanged = 0;
 242 for (my $i=0; $i<@dirschanged; ++$i)
 243   {
 244     if ($dirschanged[$i] eq '/')
 245       {
 246         $rootchanged = 1;
 247       }
 248     else
 249       {
 250         $dirschanged[$i] =~ s#^(.+)[/\\]$#$1#;
 251       }
 252   }
 253
 254 # Figure out what files have changed using svnlook.
 255 @svnlooklines = &read_from_process($svnlook, 'changed', $repos, '-r', $rev);
 256
 257 # Parse the changed nodes.
 258 my @adds;
 259 my @dels;
 260 my @mods;
 261 foreach my $line (@svnlooklines)
 262   {
 263     my $path = '';
 264     my $code = '';
 265
 266     # Split the line up into the modification code and path, ignoring
 267     # property modifications.
 268     if ($line =~ /^(.).  (.*)$/)
 269       {
 270         $code = $1;
 271         $path = $2;
 272       }
 273
 274     if ($code eq 'A')
 275       {
 276         push(@adds, $path);
 277       }
 278     elsif ($code eq 'D')
 279       {
 280         push(@dels, $path);
 281       }
 282     else
 283       {
 284         push(@mods, $path);
 285       }
 286   }
 287
 288 # Get the diff from svnlook.
 289 my @no_diff_deleted = $no_diff_deleted ? ('--no-diff-deleted') : ();
 290 my @no_diff_added = $no_diff_added ? ('--no-diff-added') : ();
 291 my @difflines = &read_from_process($svnlook, 'diff', $repos,
 292                                    '-r', $rev, @no_diff_deleted,
 293                                    @no_diff_added);
 294
 295 ######################################################################
 296 # Modified directory name collapsing.
 297
 298 # Collapse the list of changed directories only if the root directory
 299 # was not modified, because otherwise everything is under root and
 300 # there's no point in collapsing the directories, and only if more
 301 # than one directory was modified.
 302 my $commondir = '';
 303 my @dirschanged_orig = @dirschanged;
 304 if (!$rootchanged and @dirschanged > 1)
 305   {
 306     my $firstline    = shift @dirschanged;
 307     my @commonpieces = split('/', $firstline);
 308     foreach my $line (@dirschanged)
 309       {
 310         my @pieces = split('/', $line);
 311         my $i = 0;
 312         while ($i < @pieces and $i < @commonpieces)
 313           {
 314             if ($pieces[$i] ne $commonpieces[$i])
 315               {
 316                 splice(@commonpieces, $i, @commonpieces - $i);
 317                 last;
 318               }
 319             $i++;
 320           }
 321       }
 322     unshift(@dirschanged, $firstline);
 323
 324     if (@commonpieces)
 325       {
 326         $commondir = join('/', @commonpieces);
 327         my @new_dirschanged;
 328         foreach my $dir (@dirschanged)
 329           {
 330             if ($dir eq $commondir)
 331               {
 332                 $dir = '.';
 333               }
 334             else
 335               {
 336                 $dir =~ s#^\Q$commondir/\E##;
 337               }
 338             push(@new_dirschanged, $dir);
 339           }
 340         @dirschanged = @new_dirschanged;
 341       }
 342   }
 343 my $dirlist = join(' ', @dirschanged);
 344
 345 ######################################################################
 346 # Assembly of log message.
 347
 348 # Put together the body of the log message.
 349 my @body;
 350 push(@body, "Author: $author\n");
 351 push(@body, "Date: $date\n");
 352 push(@body, "New Revision: $rev\n");
 353 push(@body, "\n");
 354 if (@adds)
 355   {
 356     @adds = sort @adds;
 357     push(@body, "Added:\n");
 358     push(@body, map { "   $_\n" } @adds);
 359   }
 360 if (@dels)
 361   {
 362     @dels = sort @dels;
 363     push(@body, "Removed:\n");
 364     push(@body, map { "   $_\n" } @dels);
 365   }
 366 if (@mods)
 367   {
 368     @mods = sort @mods;
 369     push(@body, "Modified:\n");
 370     push(@body, map { "   $_\n" } @mods);
 371   }
 372 push(@body, "Log:\n");
 373 push(@body, @log);
 374 push(@body, "\n");
 375 push(@body, map { /[\r\n]+$/ ? $_ : "$_\n" } @difflines);
 376
 377 # Go through each project and see if there are any matches for this
 378 # project.  If so, send the log out.
 379 foreach my $project (@project_settings_list)
 380   {
 381     my $match_re = $project->{match_re};
 382     my $match    = 0;
 383     foreach my $path (@dirschanged_orig, @adds, @dels, @mods)
 384       {
 385         if ($path =~ $match_re)
 386           {
 387             $match = 1;
 388             last;
 389           }
 390       }
 391
 392     next unless $match;
 393
 394     my @email_addresses = @{$project->{email_addresses}};
 395     my $userlist        = join(' ', @email_addresses);
 396     my $to              = join(', ', @email_addresses);
 397     my $from_address    = $project->{from_address};
 398     my $hostname        = $project->{hostname};
 399     my $log_file        = $project->{log_file};
 400     my $reply_to        = $project->{reply_to};
 401     my $subject_prefix  = $project->{subject_prefix};
 402     my $subject;
 403
 404     if ($commondir ne '')
 405       {
 406         $subject = "r$rev - in $commondir: $dirlist";
 407       }
 408     else
 409       {
 410         $subject = "r$rev - $dirlist";
 411       }
 412     if ($subject_prefix =~ /\w/)
 413       {
 414         $subject = "$subject_prefix $subject";
 415       }
 416     my $mail_from = $author;
 417
 418     if ($from_address =~ /\w/)
 419       {
 420         $mail_from = $from_address;
 421       }
 422     elsif ($hostname =~ /\w/)
 423       {
 424         $mail_from = "$mail_from\@$hostname";
 425       }
 426
 427     my @head;
 428     push(@head, "To: $to\n");
 429     push(@head, "From: $mail_from\n");
 430     push(@head, "Subject: $subject\n");
 431     push(@head, "Reply-to: $reply_to\n") if $reply_to;
 432
 433     ### Below, we set the content-type etc, but see these comments
 434     ### from Greg Stein on why this is not a full solution.
 435     #
 436     # From: Greg Stein <gstein@lyra.org>
 437     # Subject: Re: svn commit: rev 2599 - trunk/tools/cgi
 438     # To: dev@subversion.tigris.org
 439     # Date: Fri, 19 Jul 2002 23:42:32 -0700
 440     #
 441     # Well... that isn't strictly true. The contents of the files
 442     # might not be UTF-8, so the "diff" portion will be hosed.
 443     #
 444     # If you want a truly "proper" commit message, then you'd use
 445     # multipart MIME messages, with each file going into its own part,
 446     # and labeled with an appropriate MIME type and charset. Of
 447     # course, we haven't defined a charset property yet, but no biggy.
 448     #
 449     # Going with multipart will surely throw out the notion of "cut
 450     # out the patch from the email and apply." But then again: the
 451     # commit emailer could see that all portions are in the same
 452     # charset and skip the multipart thang.
 453     #
 454     # etc etc
 455     #
 456     # Basically: adding/tweaking the content-type is nice, but don't
 457     # think that is the proper solution.
 458     push(@head, "Content-Type: text/plain; charset=UTF-8\n");
 459     push(@head, "Content-Transfer-Encoding: 8bit\n");
 460
 461     push(@head, "\n");
 462
 463     if ($sendmail =~ /\w/ and @email_addresses)
 464       {
 465         # Open a pipe to sendmail.
 466         my $command = "$sendmail -f$mail_from $userlist";
 467         if (open(SENDMAIL, "| $command"))
 468           {
 469             print SENDMAIL @head, @body;
 470             close SENDMAIL
 471               or warn "$0: error in closing `$command' for writing: $!\n";
 472           }
 473         else
 474           {
 475             warn "$0: cannot open `| $command' for writing: $!\n";
 476           }
 477       }
 478
 479     # Dump the output to logfile (if its name is not empty).
 480     if ($log_file =~ /\w/)
 481       {
 482         if (open(LOGFILE, ">> $log_file"))
 483           {
 484             print LOGFILE @head, @body;
 485             close LOGFILE
 486               or warn "$0: error in closing `$log_file' for appending: $!\n";
 487           }
 488         else
 489           {
 490             warn "$0: cannot open `$log_file' for appending: $!\n";
 491           }
 492       }
 493   }
 494
 495 exit 0;
 496
 497 sub usage
 498 {
 499   warn "@_\n" if @_;
 500   die "usage: $0 REPOS REVNUM [[-m regex] [options] [email_addr ...]] ...\n",
 501       "options are\n",
 502       "  --from email_address  Email address for 'From:' (overrides -h)\n",
 503       "  -h hostname           Hostname to append to author for 'From:'\n",
 504       "  -l logfile            Append mail contents to this log file\n",
 505       "  -m regex              Regular expression to match committed path\n",
 506       "  -r email_address      Email address for 'Reply-To:'\n",
 507       "  -s subject_prefix     Subject line prefix\n",
 508       "\n",
 509       "This script supports a single repository with multiple projects,\n",
 510       "where each project receives email only for commits that modify that\n",
 511       "project.  A project is identified by using the -m command line\n",
 512       "with a regular expression argument.  If a commit has a path that\n",
 513       "matches the regular expression, then the entire commit matches.\n",
 514       "Any of the following -h, -l, -r and -s command line options and\n",
 515       "following email addresses are associated with this project.  The\n",
 516       "next -m resets the -h, -l, -r and -s command line options and the\n",
 517       "list of email addresses.\n",
 518       "\n",
 519       "To support a single project conveniently, the script initializes\n",
 520       "itself with an implicit -m . rule that matches any modifications\n",
 521       "to the repository.  Therefore, to use the script for a single\n",
 522       "project repository, just use the other comand line options and\n",
 523       "a list of email addresses on the command line.  If you do not want\n",
 524       "a project that matches the entire repository, then use a -m with a\n",
 525       "regular expression before any other command line options or email\n",
 526       "addresses.\n";
 527 }
 528
 529 # Return a new hash data structure for a new empty project that
 530 # matches any modifications to the repository.
 531 sub new_project
 532 {
 533   return {email_addresses => [],
 534           from_address    => '',
 535           hostname        => '',
 536           log_file        => '',
 537           match_regex     => '.',
 538           reply_to        => '',
 539           subject_prefix  => ''};
 540 }
 541
 542 # Start a child process safely without using /bin/sh.
 543 sub safe_read_from_pipe
 544 {
 545   unless (@_)
 546     {
 547       croak "$0: safe_read_from_pipe passed no arguments.\n";
 548     }
 549
 550   my $pid = open(SAFE_READ, '-|');
 551   unless (defined $pid)
 552     {
 553       die "$0: cannot fork: $!\n";
 554     }
 555   unless ($pid)
 556     {
 557       open(STDERR, ">&STDOUT")
 558         or die "$0: cannot dup STDOUT: $!\n";
 559       exec(@_)
 560         or die "$0: cannot exec `@_': $!\n";
 561     }
 562   my @output;
 563   while (<SAFE_READ>)
 564     {
 565       s/[\r\n]+$//;
 566       push(@output, $_);
 567     }
 568   close(SAFE_READ);
 569   my $result = $?;
 570   my $exit   = $result >> 8;
 571   my $signal = $result & 127;
 572   my $cd     = $result & 128 ? "with core dump" : "";
 573   if ($signal or $cd)
 574     {
 575       warn "$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n";
 576     }
 577   if (wantarray)
 578     {
 579       return ($result, @output);
 580     }
 581   else
 582     {
 583       return $result;
 584     }
 585 }
 586
 587 # Use safe_read_from_pipe to start a child process safely and return
 588 # the output if it succeeded or an error message followed by the output
 589 # if it failed.
 590 sub read_from_process
 591 {
 592   unless (@_)
 593     {
 594       croak "$0: read_from_process passed no arguments.\n";
 595     }
 596   my ($status, @output) = &safe_read_from_pipe(@_);
 597   if ($status)
 598     {
 599       return ("$0: `@_' failed with this output:", @output);
 600     }
 601   else
 602     {
 603       return @output;
 604     }
 605 }