source: trunk/locker/sbin/commit-email.pl @ 1230

Last change on this file since 1230 was 719, checked in by price, 14 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
Line 
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: 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#
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.
32BEGIN {
33  if ( $] >= 5.006_000)
34    { require warnings; import warnings; }
35  else
36    { $^W = 1; }
37}
38
39use strict;
40use Carp;
41use POSIX qw(strftime);
42my ($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.
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;
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;
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
104require 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.
112my @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!
122my $repos;
123my $rev;
124my $author;
125my $propname;
126
127my $mode = 'commit';
128my $date;
129my $diff_file;
130
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',
138                       '--revprop-change' => '',
139                       '-d'     => '',
140                       '-h'     => 'hostname',
141                       '-l'     => 'log_file',
142                       '-m'     => '',
143                       '-r'     => 'reply_to',
144                       '-s'     => 'subject_prefix',
145                       '--summary' => '',
146                       '--diff' => '',
147                       '--stdout' => '');
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
160        my $value;
161        if ($arg ne '--revprop-change' and $arg ne '--stdout' and $arg ne '--summary')
162          {
163            unless (@ARGV)
164              {
165                die "$0: command line option `$arg' is missing a value.\n";
166              }
167            $value = shift @ARGV;
168          }
169
170        if ($hash_key)
171          {
172            $current_project->{$hash_key} = $value;
173          }
174        else
175          {
176            if ($arg eq '-m')
177              {
178                $current_project                = &new_project;
179                $current_project->{match_regex} = $value;
180                push(@project_settings_list, $current_project);
181              }
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              }
222          }
223      }
224    else
225      {
226        if (! defined $repos)
227          {
228            $repos = $arg;
229          }
230        elsif (! defined $rev)
231          {
232            $rev = $arg;
233          }
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          }
242        else
243          {
244            push(@{$current_project->{email_addresses}}, $arg);
245          }
246      }
247  }
248
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  }
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
301# Harvest common data needed for both commit or revprop-change.
302
303# Figure out what directories have changed using svnlook.
304my @dirschanged = &read_from_process($svnlook, 'dirs-changed', $repos,
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.
323my @svnlooklines = &read_from_process($svnlook, 'changed', $repos, '-r', $rev);
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
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.
363
364if ($mode eq 'commit')
365  {
366    ######################################################################
367    # Harvest data using svnlook.
368
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)
386      {
387        my $firstline    = shift @edited_dirschanged;
388        my @commonpieces = split('/', $firstline);
389        foreach my $line (@edited_dirschanged)
390          {
391            my @pieces = split('/', $line);
392            my $i = 0;
393            while ($i < @pieces and $i < @commonpieces)
394              {
395                if ($pieces[$i] ne $commonpieces[$i])
396                  {
397                    splice(@commonpieces, $i, @commonpieces - $i);
398                    last;
399                  }
400                $i++;
401              }
402          }
403        unshift(@edited_dirschanged, $firstline);
404
405        if (@commonpieces)
406          {
407            $commondir = join('/', @commonpieces);
408            my @new_dirschanged;
409            foreach my $dir (@edited_dirschanged)
410              {
411                if ($dir eq $commondir)
412                  {
413                    $dir = '.';
414                  }
415                else
416                  {
417                    $dir =~ s#^\Q$commondir/\E##;
418                  }
419                push(@new_dirschanged, $dir);
420              }
421            @edited_dirschanged = @new_dirschanged;
422          }
423      }
424    my $dirlist = join(' ', @edited_dirschanged);
425
426    ######################################################################
427    # Assembly of log message.
428
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");
467  }
468elsif ($mode eq 'revprop-change')
469  {
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");
503  }
504
505# Cached information - calculated when first needed.
506my @difflines;
507
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};
533    my $summary         = $project->{summary};
534    my $diff_wanted     = ($project->{show_diff} and $mode eq 'commit');
535    my $stdout          = $project->{stdout};
536
537    my $subject         = $summary ? $subject_logbase : $subject_base;
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      }
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      }
557
558    my @head;
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");
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
579    #
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.
582    #
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.
587    #
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
591    # charset and skip the multipart thang.
592    #
593    # etc etc
594    #
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
602    if ($diff_wanted and not @difflines)
603      {
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      {
620        # Open a pipe to sendmail.
621        my $command = "$sendmail -f'$mail_from' $userlist";
622        if (open(SENDMAIL, "| $command"))
623          {
624            print SENDMAIL @head, @body;
625            print SENDMAIL @difflines if $diff_wanted;
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      }
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      }
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;
656            print LOGFILE @difflines if $diff_wanted;
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
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
678sub usage
679{
680  warn "@_\n" if @_;
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",
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",
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",
697      "\n",
698      "This script supports a single repository with multiple projects,\n",
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",
704      "\n",
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",
709      "To support a single project conveniently, the script initializes\n",
710      "itself with an implicit -m . rule that matches any modifications\n",
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",
713      "a list of email addresses on the command line.  If you do not want\n",
714      "a rule that matches the entire repository, then use -m with a\n",
715      "regular expression before any other command line options or email\n",
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";
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        => '',
734          subject_prefix  => '',
735          show_diff       => 1,
736          stdout          => 0};
737}
738
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
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
755  my $openfork_available = $^O ne "MSWin32"; 
756  if ($openfork_available) # We can fork on this system.
757    {
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        }
770    }
771  else  # Running on Windows.  No fork.
772    {
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";
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.