source: spip-zone/_dev_/bin_svn/commit-email.pl @ 815

Last change on this file since 815 was 815, checked in by fil@…, 15 years ago

script de creation des archives sur le serveur trac

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