source: branches/fc15-dev/locker/sbin/commit-email.pl @ 2692

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