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