tools/hook-scripts/commit-email.pl.in

   1 #!/usr/bin/env perl
   2
   3 # ====================================================================
   4 # commit-email.pl: send a notification email describing either a
   5 # commit or a revprop-change action on a Subversion repository.
   6 #
   7 # For usage, see the usage subroutine or run the script with no
   8 # command line arguments.
   9 #
  10 # This script requires Subversion 1.2.0 or later.
  11 #
  12 # $HeadURL$
  13 # $LastChangedDate$
  14 # $LastChangedBy$
  15 # $LastChangedRevision$
  16 #
  17 # ====================================================================
  18 # Copyright (c) 2000-2006 CollabNet.  All rights reserved.
  19 #
  20 # This software is licensed as described in the file COPYING, which
  21 # you should have received as part of this distribution.  The terms
  22 # are also available at http://subversion.tigris.org/license-1.html.
  23 # If newer versions of this license are posted there, you may use a
  24 # newer version instead, at your option.
  25 #
  26 # This software consists of voluntary contributions made by many
  27 # individuals.  For exact contribution history, see the revision
  28 # history and logs, available at http://subversion.tigris.org/.
  29 # ====================================================================
  30
  31 # Turn on warnings the best way depending on the Perl version.
  32 BEGIN {
  33   if ( $] >= 5.006_000)
  34     { require warnings; import warnings; }
  35   else
  36     { $^W = 1; }
  37 }
  38
  39 use strict;
  40 use Carp;
  41 use POSIX qw(strftime);
  42 my ($sendmail, $smtp_server);
  43
  44 ######################################################################
  45 # Configuration section.
  46
  47 # Sendmail path, or SMTP server address.
  48 # You should define exactly one of these two configuration variables,
  49 # leaving the other commented out, to select which method of sending
  50 # email should be used.
  51 # Using --stdout on the command line overrides both.
  52 #$sendmail = "/usr/sbin/sendmail";
  53 $smtp_server = "127.0.0.1";
  54
  55 # Svnlook path.
  56 my $svnlook = "@SVN_BINDIR@/svnlook";
  57
  58 # By default, when a file is deleted from the repository, svnlook diff
  59 # prints the entire contents of the file.  If you want to save space
  60 # in the log and email messages by not printing the file, then set
  61 # $no_diff_deleted to 1.
  62 my $no_diff_deleted = 0;
  63 # By default, when a file is added to the repository, svnlook diff
  64 # prints the entire contents of the file.  If you want to save space
  65 # in the log and email messages by not printing the file, then set
  66 # $no_diff_added to 1.
  67 my $no_diff_added = 0;
  68
  69 # End of Configuration section.
  70 ######################################################################
  71
  72 # Check that the required programs exist, and the email sending method
  73 # configuration is sane, to ensure that the administrator has set up
  74 # the script properly.
  75 {
  76   my $ok = 1;
  77   foreach my $program ($sendmail, $svnlook)
  78     {
  79       next if not defined $program;
  80       if (-e $program)
  81         {
  82           unless (-x $program)
  83             {
  84               warn "$0: required program `$program' is not executable, ",
  85                    "edit $0.\n";
  86               $ok = 0;
  87             }
  88         }
  89       else
  90         {
  91           warn "$0: required program `$program' does not exist, edit $0.\n";
  92           $ok = 0;
  93         }
  94     }
  95   if (not (defined $sendmail xor defined $smtp_server))
  96     {
  97       warn "$0: exactly one of \$sendmail or \$smtp_server must be ",
  98            "set, edit $0.\n";
  99       $ok = 0;
 100     }
 101   exit 1 unless $ok;
 102 }
 103
 104 require Net::SMTP if defined $smtp_server;
 105
 106 ######################################################################
 107 # Initial setup/command-line handling.
 108
 109 # Each value in this array holds a hash reference which contains the
 110 # associated email information for one project.  Start with an
 111 # implicit rule that matches all paths.
 112 my @project_settings_list = (&new_project);
 113
 114 # Process the command line arguments till there are none left.
 115 # In commit mode: The first two arguments that are not used by a command line
 116 # option are the repository path and the revision number.
 117 # In revprop-change mode: The first four arguments that are not used by a
 118 # command line option are the repository path, the revision number, the
 119 # author, and the property name. This script has no support for the fifth
 120 # argument (action) added to the post-revprop-change hook in Subversion
 121 # 1.2.0 yet - patches welcome!
 122 my $repos;
 123 my $rev;
 124 my $author;
 125 my $propname;
 126
 127 my $mode = 'commit';
 128 my $date;
 129 my $diff_file;
 130
 131 # Use the reference to the first project to populate.
 132 my $current_project = $project_settings_list[0];
 133
 134 # This hash matches the command line option to the hash key in the
 135 # project.  If a key exists but has a false value (''), then the
 136 # command line option is allowed but requires special handling.
 137 my %opt_to_hash_key = ('--from' => 'from_address',
 138                        '--revprop-change' => '',
 139                        '-d'     => '',
 140                        '-h'     => 'hostname',
 141                        '-l'     => 'log_file',
 142                        '-m'     => '',
 143                        '-r'     => 'reply_to',
 144                        '-s'     => 'subject_prefix',
 145                        '--diff' => '',
 146                        '--stdout' => '');
 147
 148 while (@ARGV)
 149   {
 150     my $arg = shift @ARGV;
 151     if ($arg =~ /^-/)
 152       {
 153         my $hash_key = $opt_to_hash_key{$arg};
 154         unless (defined $hash_key)
 155           {
 156             die "$0: command line option `$arg' is not recognized.\n";
 157           }
 158
 159         my $value;
 160         if ($arg ne '--revprop-change' and $arg ne '--stdout')
 161           {
 162             unless (@ARGV)
 163               {
 164                 die "$0: command line option `$arg' is missing a value.\n";
 165               }
 166             $value = shift @ARGV;
 167           }
 168
 169         if ($hash_key)
 170           {
 171             $current_project->{$hash_key} = $value;
 172           }
 173         else
 174           {
 175             if ($arg eq '-m')
 176               {
 177                 $current_project                = &new_project;
 178                 $current_project->{match_regex} = $value;
 179                 push(@project_settings_list, $current_project);
 180               }
 181             elsif ($arg eq '-d')
 182               {
 183                 if ($mode ne 'revprop-change')
 184                   {
 185                     die "$0: `-d' is valid only when used after"
 186                       . " `--revprop-change'.\n";
 187                   }
 188                 if ($diff_file)
 189                   {
 190                     die "$0: command line option `$arg'"
 191                       . " can only be used once.\n";
 192                   }
 193                 $diff_file = $value;
 194               }
 195             elsif ($arg eq '--revprop-change')
 196               {
 197                 if (defined $repos)
 198                   {
 199                     die "$0: `--revprop-change' must be specified before"
 200                       . " the first non-option argument.\n";
 201                   }
 202                 $mode = 'revprop-change';
 203               }
 204             elsif ($arg eq '--diff')
 205               {
 206                 $current_project->{show_diff} = parse_boolean($value);
 207               }
 208             elsif ($arg eq '--stdout')
 209               {
 210                 $current_project->{stdout} = 1;
 211               }
 212             else
 213               {
 214                 die "$0: internal error:"
 215                   . " should not be handling `$arg' here.\n";
 216               }
 217           }
 218       }
 219     else
 220       {
 221         if (! defined $repos)
 222           {
 223             $repos = $arg;
 224           }
 225         elsif (! defined $rev)
 226           {
 227             $rev = $arg;
 228           }
 229         elsif (! defined $author && $mode eq 'revprop-change')
 230           {
 231             $author = $arg;
 232           }
 233         elsif (! defined $propname && $mode eq 'revprop-change')
 234           {
 235             $propname = $arg;
 236           }
 237         else
 238           {
 239             push(@{$current_project->{email_addresses}}, $arg);
 240           }
 241       }
 242   }
 243
 244 if ($mode eq 'commit')
 245   {
 246     &usage("$0: too few arguments.") unless defined $rev;
 247   }
 248 elsif ($mode eq 'revprop-change')
 249   {
 250     &usage("$0: too few arguments.") unless defined $propname;
 251   }
 252
 253 # Check the validity of the command line arguments.  Check that the
 254 # revision is an integer greater than 0 and that the repository
 255 # directory exists.
 256 unless ($rev =~ /^\d+/ and $rev > 0)
 257   {
 258     &usage("$0: revision number `$rev' must be an integer > 0.");
 259   }
 260 unless (-e $repos)
 261   {
 262     &usage("$0: repos directory `$repos' does not exist.");
 263   }
 264 unless (-d _)
 265   {
 266     &usage("$0: repos directory `$repos' is not a directory.");
 267   }
 268
 269 # Check that all of the regular expressions can be compiled and
 270 # compile them.
 271 {
 272   my $ok = 1;
 273   for (my $i=0; $i<@project_settings_list; ++$i)
 274     {
 275       my $match_regex = $project_settings_list[$i]->{match_regex};
 276
 277       # To help users that automatically write regular expressions
 278       # that match the root directory using ^/, remove the / character
 279       # because subversion paths, while they start at the root level,
 280       # do not begin with a /.
 281       $match_regex =~ s#^\^/#^#;
 282
 283       my $match_re;
 284       eval { $match_re = qr/$match_regex/ };
 285       if ($@)
 286         {
 287           warn "$0: -m regex #$i `$match_regex' does not compile:\n$@\n";
 288           $ok = 0;
 289           next;
 290         }
 291       $project_settings_list[$i]->{match_re} = $match_re;
 292     }
 293   exit 1 unless $ok;
 294 }
 295
 296 # Harvest common data needed for both commit or revprop-change.
 297
 298 # Figure out what directories have changed using svnlook.
 299 my @dirschanged = &read_from_process($svnlook, 'dirs-changed', $repos,
 300                                      '-r', $rev);
 301
 302 # Lose the trailing slash in the directory names if one exists, except
 303 # in the case of '/'.
 304 my $rootchanged = 0;
 305 for (my $i=0; $i<@dirschanged; ++$i)
 306   {
 307     if ($dirschanged[$i] eq '/')
 308       {
 309         $rootchanged = 1;
 310       }
 311     else
 312       {
 313         $dirschanged[$i] =~ s#^(.+)[/\\]$#$1#;
 314       }
 315   }
 316
 317 # Figure out what files have changed using svnlook.
 318 my @svnlooklines = &read_from_process($svnlook, 'changed', $repos, '-r', $rev);
 319
 320 # Parse the changed nodes.
 321 my @adds;
 322 my @dels;
 323 my @mods;
 324 foreach my $line (@svnlooklines)
 325   {
 326     my $path = '';
 327     my $code = '';
 328
 329     # Split the line up into the modification code and path, ignoring
 330     # property modifications.
 331     if ($line =~ /^(.).  (.*)$/)
 332       {
 333         $code = $1;
 334         $path = $2;
 335       }
 336
 337     if ($code eq 'A')
 338       {
 339         push(@adds, $path);
 340       }
 341     elsif ($code eq 'D')
 342       {
 343         push(@dels, $path);
 344       }
 345     else
 346       {
 347         push(@mods, $path);
 348       }
 349   }
 350
 351 # Declare variables which carry information out of the inner scope of
 352 # the conditional blocks below.
 353 my $subject_base;
 354 my @body;
 355 # $author - declared above for use as a command line parameter in
 356 #   revprop-change mode.  In commit mode, gets filled in below.
 357
 358 if ($mode eq 'commit')
 359   {
 360     ######################################################################
 361     # Harvest data using svnlook.
 362
 363     # Get the author, date, and log from svnlook.
 364     my @infolines = &read_from_process($svnlook, 'info', $repos, '-r', $rev);
 365     $author = shift @infolines;
 366     $date = shift @infolines;
 367     shift @infolines;
 368     my @log = map { "$_\n" } @infolines;
 369
 370     ######################################################################
 371     # Modified directory name collapsing.
 372
 373     # Collapse the list of changed directories only if the root directory
 374     # was not modified, because otherwise everything is under root and
 375     # there's no point in collapsing the directories, and only if more
 376     # than one directory was modified.
 377     my $commondir = '';
 378     my @edited_dirschanged = @dirschanged;
 379     if (!$rootchanged and @edited_dirschanged > 1)
 380       {
 381         my $firstline    = shift @edited_dirschanged;
 382         my @commonpieces = split('/', $firstline);
 383         foreach my $line (@edited_dirschanged)
 384           {
 385             my @pieces = split('/', $line);
 386             my $i = 0;
 387             while ($i < @pieces and $i < @commonpieces)
 388               {
 389                 if ($pieces[$i] ne $commonpieces[$i])
 390                   {
 391                     splice(@commonpieces, $i, @commonpieces - $i);
 392                     last;
 393                   }
 394                 $i++;
 395               }
 396           }
 397         unshift(@edited_dirschanged, $firstline);
 398
 399         if (@commonpieces)
 400           {
 401             $commondir = join('/', @commonpieces);
 402             my @new_dirschanged;
 403             foreach my $dir (@edited_dirschanged)
 404               {
 405                 if ($dir eq $commondir)
 406                   {
 407                     $dir = '.';
 408                   }
 409                 else
 410                   {
 411                     $dir =~ s#^\Q$commondir/\E##;
 412                   }
 413                 push(@new_dirschanged, $dir);
 414               }
 415             @edited_dirschanged = @new_dirschanged;
 416           }
 417       }
 418     my $dirlist = join(' ', @edited_dirschanged);
 419
 420     ######################################################################
 421     # Assembly of log message.
 422
 423     if ($commondir ne '')
 424       {
 425         $subject_base = "r$rev - in $commondir: $dirlist";
 426       }
 427     else
 428       {
 429         $subject_base = "r$rev - $dirlist";
 430       }
 431
 432     # Put together the body of the log message.
 433     push(@body, "Author: $author\n");
 434     push(@body, "Date: $date\n");
 435     push(@body, "New Revision: $rev\n");
 436     push(@body, "\n");
 437     if (@adds)
 438       {
 439         @adds = sort @adds;
 440         push(@body, "Added:\n");
 441         push(@body, map { "   $_\n" } @adds);
 442       }
 443     if (@dels)
 444       {
 445         @dels = sort @dels;
 446         push(@body, "Removed:\n");
 447         push(@body, map { "   $_\n" } @dels);
 448       }
 449     if (@mods)
 450       {
 451         @mods = sort @mods;
 452         push(@body, "Modified:\n");
 453         push(@body, map { "   $_\n" } @mods);
 454       }
 455     push(@body, "Log:\n");
 456     push(@body, @log);
 457     push(@body, "\n");
 458   }
 459 elsif ($mode eq 'revprop-change')
 460   {
 461     ######################################################################
 462     # Harvest data.
 463
 464     my @svnlines;
 465     # Get the diff file if it was provided, otherwise the property value.
 466     if ($diff_file)
 467       {
 468         open(DIFF_FILE, $diff_file) or die "$0: cannot read `$diff_file': $!\n";
 469         @svnlines = <DIFF_FILE>;
 470         close DIFF_FILE;
 471       }
 472     else
 473       {
 474         @svnlines = &read_from_process($svnlook, 'propget', '--revprop', '-r',
 475                                        $rev, $repos, $propname);
 476       }
 477
 478     ######################################################################
 479     # Assembly of log message.
 480
 481     $subject_base = "propchange - r$rev $propname";
 482
 483     # Put together the body of the log message.
 484     push(@body, "Author: $author\n");
 485     push(@body, "Revision: $rev\n");
 486     push(@body, "Property Name: $propname\n");
 487     push(@body, "\n");
 488     unless ($diff_file)
 489       {
 490         push(@body, "New Property Value:\n");
 491       }
 492     push(@body, map { /[\r\n]+$/ ? $_ : "$_\n" } @svnlines);
 493     push(@body, "\n");
 494   }
 495
 496 # Cached information - calculated when first needed.
 497 my @difflines;
 498
 499 # Go through each project and see if there are any matches for this
 500 # project.  If so, send the log out.
 501 foreach my $project (@project_settings_list)
 502   {
 503     my $match_re = $project->{match_re};
 504     my $match    = 0;
 505     foreach my $path (@dirschanged, @adds, @dels, @mods)
 506       {
 507         if ($path =~ $match_re)
 508           {
 509             $match = 1;
 510             last;
 511           }
 512       }
 513
 514     next unless $match;
 515
 516     my @email_addresses = @{$project->{email_addresses}};
 517     my $userlist        = join(' ', @email_addresses);
 518     my $to              = join(', ', @email_addresses);
 519     my $from_address    = $project->{from_address};
 520     my $hostname        = $project->{hostname};
 521     my $log_file        = $project->{log_file};
 522     my $reply_to        = $project->{reply_to};
 523     my $subject_prefix  = $project->{subject_prefix};
 524     my $subject         = $subject_base;
 525     my $diff_wanted     = ($project->{show_diff} and $mode eq 'commit');
 526     my $stdout          = $project->{stdout};
 527
 528     if ($subject_prefix =~ /\w/)
 529       {
 530         $subject = "$subject_prefix $subject";
 531       }
 532     my $mail_from = $author;
 533
 534     if ($from_address =~ /\w/)
 535       {
 536         $mail_from = $from_address;
 537       }
 538     elsif ($hostname =~ /\w/)
 539       {
 540         $mail_from = "$mail_from\@$hostname";
 541       }
 542     elsif (defined $smtp_server and ! $stdout)
 543       {
 544         die "$0: use of either `-h' or `--from' is mandatory when ",
 545             "sending email using direct SMTP.\n";
 546       }
 547
 548     my @head;
 549     my $formatted_date;
 550     if (defined $stdout)
 551       {
 552         $formatted_date = strftime('%a %b %e %X %Y', localtime());
 553         push(@head, "From $mail_from $formatted_date\n");
 554       }
 555     $formatted_date = strftime('%a, %e %b %Y %X %z', localtime());
 556     push(@head, "Date: $formatted_date\n");
 557     push(@head, "To: $to\n");
 558     push(@head, "From: $mail_from\n");
 559     push(@head, "Subject: $subject\n");
 560     push(@head, "Reply-to: $reply_to\n") if $reply_to;
 561
 562     ### Below, we set the content-type etc, but see these comments
 563     ### from Greg Stein on why this is not a full solution.
 564     #
 565     # From: Greg Stein <gstein@lyra.org>
 566     # Subject: Re: svn commit: rev 2599 - trunk/tools/cgi
 567     # To: dev@subversion.tigris.org
 568     # Date: Fri, 19 Jul 2002 23:42:32 -0700
 569     #
 570     # Well... that isn't strictly true. The contents of the files
 571     # might not be UTF-8, so the "diff" portion will be hosed.
 572     #
 573     # If you want a truly "proper" commit message, then you'd use
 574     # multipart MIME messages, with each file going into its own part,
 575     # and labeled with an appropriate MIME type and charset. Of
 576     # course, we haven't defined a charset property yet, but no biggy.
 577     #
 578     # Going with multipart will surely throw out the notion of "cut
 579     # out the patch from the email and apply." But then again: the
 580     # commit emailer could see that all portions are in the same
 581     # charset and skip the multipart thang.
 582     #
 583     # etc etc
 584     #
 585     # Basically: adding/tweaking the content-type is nice, but don't
 586     # think that is the proper solution.
 587     push(@head, "Content-Type: text/plain; charset=UTF-8\n");
 588     push(@head, "Content-Transfer-Encoding: 8bit\n");
 589
 590     push(@head, "\n");
 591
 592     if ($diff_wanted and not @difflines)
 593       {
 594         # Get the diff from svnlook.
 595         my @no_diff_deleted = $no_diff_deleted ? ('--no-diff-deleted') : ();
 596         my @no_diff_added = $no_diff_added ? ('--no-diff-added') : ();
 597         @difflines = &read_from_process($svnlook, 'diff', $repos,
 598                                         '-r', $rev, @no_diff_deleted,
 599                                         @no_diff_added);
 600         @difflines = map { /[\r\n]+$/ ? $_ : "$_\n" } @difflines;
 601       }
 602
 603     if ($stdout)
 604       {
 605         print @head, @body;
 606         print @difflines if $diff_wanted;
 607       }
 608     elsif (defined $sendmail and @email_addresses)
 609       {
 610         # Open a pipe to sendmail.
 611         my $command = "$sendmail -f'$mail_from' $userlist";
 612         if (open(SENDMAIL, "| $command"))
 613           {
 614             print SENDMAIL @head, @body;
 615             print SENDMAIL @difflines if $diff_wanted;
 616             close SENDMAIL
 617               or warn "$0: error in closing `$command' for writing: $!\n";
 618           }
 619         else
 620           {
 621             warn "$0: cannot open `| $command' for writing: $!\n";
 622           }
 623       }
 624     elsif (defined $smtp_server and @email_addresses)
 625       {
 626         my $smtp = Net::SMTP->new($smtp_server)
 627           or die "$0: error opening SMTP session to `$smtp_server': $!\n";
 628         handle_smtp_error($smtp, $smtp->mail($mail_from));
 629         handle_smtp_error($smtp, $smtp->recipient(@email_addresses));
 630         handle_smtp_error($smtp, $smtp->data());
 631         handle_smtp_error($smtp, $smtp->datasend(@head, @body));
 632         if ($diff_wanted)
 633           {
 634             handle_smtp_error($smtp, $smtp->datasend(@difflines));
 635           }
 636         handle_smtp_error($smtp, $smtp->dataend());
 637         handle_smtp_error($smtp, $smtp->quit());
 638       }
 639
 640     # Dump the output to logfile (if its name is not empty).
 641     if ($log_file =~ /\w/)
 642       {
 643         if (open(LOGFILE, ">> $log_file"))
 644           {
 645             print LOGFILE @head, @body;
 646             print LOGFILE @difflines if $diff_wanted;
 647             close LOGFILE
 648               or warn "$0: error in closing `$log_file' for appending: $!\n";
 649           }
 650         else
 651           {
 652             warn "$0: cannot open `$log_file' for appending: $!\n";
 653           }
 654       }
 655   }
 656
 657 exit 0;
 658
 659 sub handle_smtp_error
 660 {
 661   my ($smtp, $retval) = @_;
 662   if (not $retval)
 663     {
 664       die "$0: SMTP Error: " . $smtp->message() . "\n";
 665     }
 666 }
 667
 668 sub usage
 669 {
 670   warn "@_\n" if @_;
 671   die "usage (commit mode):\n",
 672       "  $0 REPOS REVNUM [[-m regex] [options] [email_addr ...]] ...\n",
 673       "usage: (revprop-change mode):\n",
 674       "  $0 --revprop-change REPOS REVNUM USER PROPNAME [-d diff_file] \\\n",
 675       "    [[-m regex] [options] [email_addr ...]] ...\n",
 676       "options are:\n",
 677       "  --from email_address  Email address for 'From:' (overrides -h)\n",
 678       "  -h hostname           Hostname to append to author for 'From:'\n",
 679       "  -l logfile            Append mail contents to this log file\n",
 680       "  -m regex              Regular expression to match committed path\n",
 681       "  -r email_address      Email address for 'Reply-To:'\n",
 682       "  -s subject_prefix     Subject line prefix\n",
 683       "  --diff y|n            Include diff in message (default: y)\n",
 684       "                        (applies to commit mode only)\n",
 685       "  --stdout              Spit the message in mbox format to stdout.\n",
 686       "\n",
 687       "This script supports a single repository with multiple projects,\n",
 688       "where each project receives email only for actions that affect that\n",
 689       "project.  A project is identified by using the -m command line\n".
 690       "option with a regular expression argument.  If the given revision\n",
 691       "contains modifications to a path that matches the regular\n",
 692       "expression, then the action applies to the project.\n",
 693       "\n",
 694       "Any of the following -h, -l, -r, -s and --diff command line options\n",
 695       "and following email addresses are associated with this project.  The\n",
 696       "next -m resets the -h, -l, -r, -s and --diff command line options\n",
 697       "and the list of email addresses.\n",
 698       "\n",
 699       "To support a single project conveniently, the script initializes\n",
 700       "itself with an implicit -m . rule that matches any modifications\n",
 701       "to the repository.  Therefore, to use the script for a single-\n",
 702       "project repository, just use the other command line options and\n",
 703       "a list of email addresses on the command line.  If you do not want\n",
 704       "a rule that matches the entire repository, then use -m with a\n",
 705       "regular expression before any other command line options or email\n",
 706       "addresses.\n",
 707       "\n",
 708       "'revprop-change' mode:\n",
 709       "The message will contain a copy of the diff_file if it is provided,\n",
 710       "otherwise a copy of the (assumed to be new) property value.\n",
 711       "\n";
 712 }
 713
 714 # Return a new hash data structure for a new empty project that
 715 # matches any modifications to the repository.
 716 sub new_project
 717 {
 718   return {email_addresses => [],
 719           from_address    => '',
 720           hostname        => '',
 721           log_file        => '',
 722           match_regex     => '.',
 723           reply_to        => '',
 724           subject_prefix  => '',
 725           show_diff       => 1,
 726           stdout          => 0};
 727 }
 728
 729 sub parse_boolean
 730 {
 731   if ($_[0] eq 'y') { return 1; };
 732   if ($_[0] eq 'n') { return 0; };
 733
 734   die "$0: valid boolean options are 'y' or 'n', not '$_[0]'\n";
 735 }
 736
 737 # Start a child process safely without using /bin/sh.
 738 sub safe_read_from_pipe
 739 {
 740   unless (@_)
 741     {
 742       croak "$0: safe_read_from_pipe passed no arguments.\n";
 743     }
 744
 745   my $openfork_available = $^O ne "MSWin32";
 746   if ($openfork_available) # We can fork on this system.
 747     {
 748       my $pid = open(SAFE_READ, '-|');
 749       unless (defined $pid)
 750         {
 751           die "$0: cannot fork: $!\n";
 752         }
 753       unless ($pid)
 754         {
 755           open(STDERR, ">&STDOUT")
 756             or die "$0: cannot dup STDOUT: $!\n";
 757           exec(@_)
 758             or die "$0: cannot exec `@_': $!\n";
 759         }
 760     }
 761   else  # Running on Windows.  No fork.
 762     {
 763       my @commandline = ();
 764       my $arg;
 765
 766       while ($arg = shift)
 767         {
 768           $arg =~ s/\"/\\\"/g;
 769           if ($arg eq "" or $arg =~ /\s/) { $arg = "\"$arg\""; }
 770           push(@commandline, $arg);
 771         }
 772
 773       # Now do the pipe.
 774       open(SAFE_READ, "@commandline |")
 775         or die "$0: cannot pipe to command: $!\n";
 776     }
 777   my @output;
 778   while (<SAFE_READ>)
 779     {
 780       s/[\r\n]+$//;
 781       push(@output, $_);
 782     }
 783   close(SAFE_READ);
 784   my $result = $?;
 785   my $exit   = $result >> 8;
 786   my $signal = $result & 127;
 787   my $cd     = $result & 128 ? "with core dump" : "";
 788   if ($signal or $cd)
 789     {
 790       warn "$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n";
 791     }
 792   if (wantarray)
 793     {
 794       return ($result, @output);
 795     }
 796   else
 797     {
 798       return $result;
 799     }
 800 }
 801
 802 # Use safe_read_from_pipe to start a child process safely and return
 803 # the output if it succeeded or an error message followed by the output
 804 # if it failed.
 805 sub read_from_process
 806 {
 807   unless (@_)
 808     {
 809       croak "$0: read_from_process passed no arguments.\n";
 810     }
 811   my ($status, @output) = &safe_read_from_pipe(@_);
 812   if ($status)
 813     {
 814       return ("$0: `@_' failed with this output:", @output);
 815     }
 816   else
 817     {
 818       return @output;
 819     }
 820 }