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

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