source: locker/sbin/commit-email.pl @ 713

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