Context Navigation

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

Last change on this file since 1400 was 1400, checked in by andersk, 14 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.
40	BEGIN {
41	if ( $] >= 5.006_000)
42	{ require warnings; import warnings; }
43	else
44	{ $^W = 1; }
45	}
46
47	use strict;
48	use Carp;
49	use POSIX qw(strftime);
50	my ($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.
64	my $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.
70	my $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.
75	my $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
112	require 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.
120	my @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!
130	my $repos;
131	my $rev;
132	my $author;
133	my $propname;
134
135	my $mode = 'commit';
136	my $date;
137	my $diff_file;
138
139	# Use the reference to the first project to populate.
140	my $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.
145	my %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
157	while (@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
257	if ($mode eq 'commit')
258	{
259	&usage("$0: too few arguments.") unless defined $rev;
260	}
261	elsif ($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.
269	unless ($rev =~ /^\d+/ and $rev > 0)
270	{
271	&usage("$0: revision number `$rev' must be an integer > 0.");
272	}
273	unless (-e $repos)
274	{
275	&usage("$0: repos directory `$repos' does not exist.");
276	}
277	unless (-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.
312	my @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 '/'.
317	my $rootchanged = 0;
318	for (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.
331	my @svnlooklines = &read_from_process($svnlook, 'changed', $repos, '-r', $rev);
332
333	# Parse the changed nodes.
334	my @adds;
335	my @dels;
336	my @mods;
337	foreach 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.
366	my $subject_base;
367	my $subject_logbase;
368	my @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
372	if ($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	}
476	elsif ($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.
514	my @difflines;
515
516	# Go through each project and see if there are any matches for this
517	# project. If so, send the log out.
518	foreach 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
675	exit 0;
676
677	sub handle_smtp_error
678	{
679	my ($smtp, $retval) = @_;
680	if (not $retval)
681	{
682	die "$0: SMTP Error: " . $smtp->message() . "\n";
683	}
684	}
685
686	sub 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.
734	sub 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
747	sub 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.
756	sub 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.
823	sub 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.

Download in other formats: