[375] | 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. |
---|
| 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 | |
---|
| 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. |
---|
| 87 | my @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. |
---|
| 92 | my $repos; |
---|
| 93 | my $rev; |
---|
| 94 | |
---|
| 95 | # Use the reference to the first project to populate. |
---|
| 96 | my $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. |
---|
| 101 | my %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 | |
---|
| 108 | while (@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. |
---|
| 169 | unless ($rev =~ /^\d+/ and $rev > 0) |
---|
| 170 | { |
---|
| 171 | &usage("$0: revision number `$rev' must be an integer > 0."); |
---|
| 172 | } |
---|
| 173 | unless (-e $repos) |
---|
| 174 | { |
---|
| 175 | &usage("$0: repos directory `$repos' does not exist."); |
---|
| 176 | } |
---|
| 177 | unless (-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. |
---|
| 214 | my $tmp_dir = '/tmp'; |
---|
| 215 | chdir($tmp_dir) |
---|
| 216 | or die "$0: cannot chdir `$tmp_dir': $!\n"; |
---|
| 217 | |
---|
| 218 | # Get the author, date, and log from svnlook. |
---|
| 219 | my @svnlooklines = &read_from_process($svnlook, 'info', $repos, '-r', $rev); |
---|
| 220 | my $author = shift @svnlooklines; |
---|
| 221 | my $date = shift @svnlooklines; |
---|
| 222 | shift @svnlooklines; |
---|
| 223 | my @log = map { "$_\n" } @svnlooklines; |
---|
| 224 | |
---|
| 225 | # Figure out what directories have changed using svnlook. |
---|
| 226 | my @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 '/'. |
---|
| 231 | my $rootchanged = 0; |
---|
| 232 | for (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. |
---|
| 248 | my @adds; |
---|
| 249 | my @dels; |
---|
| 250 | my @mods; |
---|
| 251 | foreach 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. |
---|
| 279 | my @no_diff_deleted = $no_diff_deleted ? ('--no-diff-deleted') : (); |
---|
| 280 | my @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. |
---|
| 290 | my $commondir = ''; |
---|
| 291 | if (!$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 | } |
---|
| 330 | my $dirlist = join(' ', @dirschanged); |
---|
| 331 | |
---|
| 332 | ###################################################################### |
---|
| 333 | # Assembly of log message. |
---|
| 334 | |
---|
| 335 | # Put together the body of the log message. |
---|
| 336 | my @body; |
---|
| 337 | push(@body, "Author: $author\n"); |
---|
| 338 | push(@body, "Date: $date\n"); |
---|
| 339 | push(@body, "New Revision: $rev\n"); |
---|
| 340 | push(@body, "\n"); |
---|
| 341 | if (@adds) |
---|
| 342 | { |
---|
| 343 | @adds = sort @adds; |
---|
| 344 | push(@body, "Added:\n"); |
---|
| 345 | push(@body, map { " $_\n" } @adds); |
---|
| 346 | } |
---|
| 347 | if (@dels) |
---|
| 348 | { |
---|
| 349 | @dels = sort @dels; |
---|
| 350 | push(@body, "Removed:\n"); |
---|
| 351 | push(@body, map { " $_\n" } @dels); |
---|
| 352 | } |
---|
| 353 | if (@mods) |
---|
| 354 | { |
---|
| 355 | @mods = sort @mods; |
---|
| 356 | push(@body, "Modified:\n"); |
---|
| 357 | push(@body, map { " $_\n" } @mods); |
---|
| 358 | } |
---|
| 359 | push(@body, "Log:\n"); |
---|
| 360 | push(@body, @log); |
---|
| 361 | push(@body, "\n"); |
---|
| 362 | push(@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. |
---|
| 366 | foreach 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 | |
---|
| 482 | exit 0; |
---|
| 483 | |
---|
| 484 | sub 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. |
---|
| 518 | sub 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. |
---|
| 530 | sub 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. |
---|
| 577 | sub 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 | } |
---|