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

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