File Coverage

blib/lib/ClearCase/ClearPrompt.pm

Criterion	Covered	Total	%
statement	50	353	14.1
branch	21	270	7.7
condition	10	175	5.7
subroutine	7	19	36.8
pod	0	11	0.0
total	88	828	10.6

package ClearCase::ClearPrompt;

require 5.001;

$VERSION = $VERSION = '1.31';
@EXPORT_OK = qw(clearprompt clearprompt_dir redirect tempname die
		$CT $TriggerSeries
);

%EXPORT_TAGS = ( 'all' => [ qw(
	clearprompt
	clearprompt_dir
	redirect
	tempname
) ] );

require Exporter;
@ISA = qw(Exporter);

# Conceptually this is "use constant MSWIN ..." but ccperl can't do that.
sub MSWIN { ($^O || $ENV{OS}) =~ /MSWin32|Windows_NT/i ? 1 : 0 }

use vars qw($TriggerSeries $StashFile);
$TriggerSeries = $ENV{CLEARCASE_CLEARPROMPT_TRIGGERSERIES};

# Make $CT read-only but not a constant so it can be interpolated.
*CT = *CT = \ccpath('cleartool');	# double assignment suppresses warning

if ($] > 5.004) {
    use strict;
    eval "use subs 'die'";  # We override this and may also export it to caller
}

my %Dialogs = ();
my %Mailings = ();
my %MailTo = (); # accumulates lists of users to mail various msgs to.

(my $prog = $0) =~ s%.*[/\\]%%;

sub rerun_in_debug_mode {
    # Re-exec ourself with debugging turned on. If in GUI mode,
    # rerun in a new window. This allows "perl -d" debugging of
    # triggers in a GUI env.
    delete $ENV{CLEARCASE_CLEARPROMPT_DEBUG};	# suppress recursion
    return if $ENV{PERL_DL_NONLAZY};		# marker for 'make test'
    my @cmd = ($^X, '-d', $0, @ARGV);
    if (MSWIN()) {
	for (@cmd) {
	    $_ = qq("$_") if m%\s%;
	}
	unshift(@cmd, qw(start /wait)) if $ENV{ATRIA_FORCE_GUI};
    } else {
	unshift(@cmd, qw(xterm -e)) if $ENV{ATRIA_FORCE_GUI};
    }
    if (MSWIN()) {
	# This does not work with ccperl (5.001) if CC is installed to
	# "C:\Program Files\...".
	my $rc = system(@cmd);
	exit($rc != 0);
    } else {
	exec(@cmd);
    }
}

sub dbg_shell {
    # Fork an interactive shell and wait for it. Useful in triggers because
    # it lets you explore the runtime environment of the trigger script.
    return if $ENV{PERL_DL_NONLAZY};		# marker for 'make test'
    my $cmd = $ENV{CLEARCASE_CLEARPROMPT_DEBUG_SHELL};
    $cmd = MSWIN() ? $ENV{COMSPEC} : '/bin/sh' unless $cmd && -x $cmd;
    if ($ENV{ATRIA_FORCE_GUI}) {
	if (MSWIN()) {
	    $cmd = "start /wait $cmd";
	} else {
	    $cmd = "xterm -e $cmd";
	}
    }
    exit 1 if system $cmd;
}

# Debugging aids. Documented in POD section. These can also be
# controlled via cmds at import time.
if ($ENV{CLEARCASE_CLEARPROMPT_DEBUG} ||
	($ENV{ATRIA_FORCE_GUI} && $ENV{PERL5OPT} && $ENV{PERL5OPT} =~ /-d/)) {
    rerun_in_debug_mode();
} elsif ($ENV{CLEARCASE_CLEARPROMPT_DEBUG_SHELL}) {
    dbg_shell();
}

# Make an attempt to supply a full path to the specified program.
# Else fall back to relying on PATH.
sub ccpath {
    my $name = shift;
    if (MSWIN()) {
	return $name;	# no way to avoid relying on PATH in &^&@$! Windows
    } else {
	return join('/', $ENV{ATRIAHOME} || q(/usr/atria), 'bin', $name);
    }
}

# Generates a random-ish name for a temp file that doesn't yet exist.
# This function makes no pretense of being atomic; it's conceivable,
# though highly unlikely, that the generated filename could be
# taken between the time it's generated and the time it's used.
# The optional parameter becomes a filename extension. The optional
# 2nd parameter overrides the basename part of the generated path.
sub tempname {
    my($custom, $tmpf) = @_;
    # The preferred directory for temp files.
    my $tmpd = MSWIN() ?
	    ($ENV{TEMP} || $ENV{TMP} || ( -d "$ENV{SYSTEMDRIVE}/temp" ?
			      "$ENV{SYSTEMDRIVE}/temp" : $ENV{SYSTEMDRIVE})) :
	    ($ENV{TMPDIR} || '/tmp');
    $tmpd =~ s%\\%/%g;
    my $ext = 'tmp';
    return "$tmpd/$tmpf.$custom.$ext" if $tmpf;
    (my $pkg = lc __PACKAGE__) =~ s/:+/-/g;
    while (1) {
	$tmpf = join('.', "$tmpd/$pkg", $$, int(rand 10000));
	$tmpf .= $custom ? ".$custom.$ext" : ".$ext";
	return $tmpf if ! -f $tmpf;
    }
}

# Run clearprompt with specified args and return what it returned. Uses the
# exact same syntax as the clearprompt executable ('ct man clearprompt')
# except for -outfile  which is handled internally here.
sub clearprompt {
    my $mode = shift;
    my @args = @_;
    my $data;

    return 0 if $ENV{ATRIA_WEB_GUI};	# must assume "" or 0 if ccweb interface

    local $!;	# don't mess up errno in the caller's world.

    # Play back responses from the StashFile if it exists and other conditions
    # are satisfied. It seems that CC sets the series id to all zeroes
    # after an error condition (??) so we avoid that case explicitly.
    my $lineno = (caller)[2];
    my $subtext = "from $prog:$lineno";
    if ($TriggerSeries && $ENV{CLEARCASE_SERIES_ID} &&
				    $ENV{CLEARCASE_SERIES_ID} !~ /^[0:.]+$/) {
	(my $sid = $ENV{CLEARCASE_SERIES_ID}) =~ s%:+%-%g;
	$StashFile = tempname($prog, "CLEARCASE_SERIES_ID=$sid");
	if (!$ENV{CLEARCASE_BEGIN_SERIES} && -f $StashFile) {
	    do $StashFile;
	    if ($ENV{CLEARCASE_END_SERIES} &&
				    !$ENV{CLEARCASE_CLEARPROMPT_KEEP_CAPTURE}) {
		# We delay the unlink due to weird  Windows locking behavior
		eval "END { unlink '$StashFile' }";
	    }
	    no strict 'vars';
	    my $data = eval "\$stash$lineno";
	    _automail('PROMPT', "Replay $subtext", "REPLAY:\n",
			    defined($data) ? $data : 'undef');
	    return $data;
	}
    }

    # On Windows we must add an extra level of escaping to any args
    # which might have special chars since all forms of system()
    # appear to go through the %^%@# cmd shell (boo!). This is
    # also handled by Perl 5.6.1, ActiveState build 630 but it will
    # be a long time till we can count on that fix being present.
    if (MSWIN()) {
	for (0..$#args) {
	    my $i = $_;
	    if ($args[$i] =~ /^-(?:pro|ite|def|dfi|dir)/) {
		$args[$i+1] =~ s/"/'/gs;
		$args[$i+1] = qq("$args[$i+1]");
	    }
	}
    }

    # For clearprompt modes in which we get textual data back via a file,
    # derive here a reasonable temp-file name and handle the details
    # of reading the data out of it and unlinking it when done.
    # For other modes, just fire off the cmd and return the status.
    # In a void context, don't wait for the button to be pushed; just
    # "fork" and proceed asynchonously since this is presumably just an
    # informational message.
    # If the cmd took a signal, return undef and leave the signal # in $?.
    if ($mode =~ /text|file|list/) {
	my $outf = tempname($mode);
	my @cmd = (ccpath('clearprompt'), $mode, '-out', $outf, @args);
	print STDERR "+ @cmd\n" if $ClearCase::ClearPrompt::Verbose;
	if (!system(@cmd)) {
	    if (open(OUTFILE, $outf)) {
		local $/ = undef;
		$data = ;
		$data = '' if !defined $data;
		close(OUTFILE);
	    }
	} else {
	    # If we took a signal, return undef with the signal # in $?. The
	    # clearprompt cmd apparently catches SIGINT and returns 0x400 for
	    # some reason; we fix it here so $? looks like a normal sig2.
	    $? = 2 if $? == 0x400;
	    $data = undef if $? && $? <= 0x80;
	}
	unlink $outf if -f $outf;
	_automail('PROMPT', "Prompt $subtext", "PROMPT:\n", "@cmd\n",
			    "\nRESPONSE:\n", defined($data) ? $data : 'undef');
    } else {
	my @cmd = (ccpath('clearprompt'), $mode, @args);
	print STDERR "+ @cmd\n" if $ClearCase::ClearPrompt::Verbose;
	if (defined wantarray) {
	    system(@cmd);
	    $? = 2 if $? == 0x400;  # see above
	    $data = ($? && $? <= 0x80) ? undef : $?>>8;
	    _automail('PROMPT', "Prompt $subtext", "PROMPT:\n",
		"@cmd\n", "\nRESPONSE:\n", defined($data) ? $data : 'undef');
	} else {
	    _automail('PROMPT', "Prompt $subtext", "PROMPT:\n", "@cmd\n");
	    if (MSWIN()) {
		# Windows (always) GUI - fork new thread to run async
		system(1, @cmd);
		return;
	    } elsif (exists $ENV{DISPLAY}) {
		# Unix GUI - must fork to run async
		return if fork;
		exec(@cmd);
	    } else {
		# Unix cmd line - must close stdin to run async
		open(SAVE_STDIN, ">&STDIN");
		close(STDIN);
		system(@cmd);
		open(STDIN, ">&SAVE_STDIN");
		close(SAVE_STDIN);
	    }
	}
    }

    # Record responses if $TriggerSeries is turned on.
    if ($StashFile) {
	if ($ENV{CLEARCASE_BEGIN_SERIES} && !$ENV{CLEARCASE_END_SERIES}) {
	    my $top = ! -f $StashFile;
	    eval { require Data::Dumper };
	    if ($@ || $] < 5.004) {
		warn "$prog: Warning: TriggerSeries requires Data::Dumper\n";
	    } else {
		open(STASH, ">>$StashFile") || die "$prog: $StashFile: $!";
		print STASH "# This file contains data stashed for $prog\n"
									if $top;
		print STASH Data::Dumper->new([$data], ["stash$lineno"])->Dump;
		close(STASH);
		if (! $ENV{CLEARCASE_CLEARPROMPT_KEEP_CAPTURE}) {
		    $SIG{INT} = sub { unlink $StashFile };
		}
	    }
	}
    }

    return $data;
}

# Fake up a directory chooser using opendir/readdir/closedir and
# 'clearprompt list'.
sub clearprompt_dir {
    require Cwd;
    require File::Spec;
    my($dir, $msg) = @_;
    my(%subdirs, $items, @drives);
    my $iwd = Cwd::abs_path('.');
    $dir = $iwd if $dir eq '.';

    return 0 if $ENV{ATRIA_WEB_GUI};	# must assume "" or 0 if ccweb interface

    while (1) {
	if (opendir(DIR, $dir)) {
	    %subdirs = map {$_ => 1} grep {-d "$dir/$_" || ! -e "$dir/$_"}
								readdir(DIR);
	    chomp %subdirs;
	    closedir(DIR);
	} else {
	    warn "$dir: $!\n";
	    $dir = File::Spec->rootdir;
	    next;
	}
	if (MSWIN() && $dir =~ m%^[A-Z]:[\\/]?$%i) {
	    delete $subdirs{'.'};
	    delete $subdirs{'..'};
	    @drives = grep {-e} map {"$_:"} 'C'..'Z' if !@drives;
	    $items = join(',', @drives, sort keys %subdirs);
	} else {
	    $items = join(',', sort keys %subdirs);
	}
	my $resp = clearprompt(qw(list -items), $items,
						    '-pro', "$msg  [ $dir ]");
	if (!defined $resp) {
	    undef $dir;
	    last;
	}
	chomp $resp;
	last if ! $resp || $resp eq '.';
	if (MSWIN() && $resp =~ m%^[A-Z]:[\\/]?$%i) {
	    $dir = $resp;
	    chdir $dir || warn "$dir: $!\n";
	} else {
	    $dir = Cwd::abs_path(File::Spec->catdir($dir, $resp));
	}
    }
    chdir $iwd || warn "$iwd: $!\n";
    return $dir;
}

# Takes args in the form "redirect(STDERR => 'OFF', STDOUT => 'ON')" and
# enables or disables stdout/stderr as specified.
sub redirect {
    # Stash these away at first use for potential future use, e.g. debugging.
    open(SAVE_STDOUT, '>&STDOUT') if !defined fileno(SAVE_STDOUT);
    open(SAVE_STDERR, '>&STDERR') if !defined fileno(SAVE_STDERR);

    while(@_) {
	my $stream = uc shift;
	my $state  = shift;

	if ($stream ne 'STDOUT' && $stream ne 'STDERR') {
	    print SAVE_STDERR "unrecognized stream $stream\n";
	    next;
	}

	if ($stream eq 'STDOUT') {
	    if ($state =~ /^OFF$/i) {
		if (defined fileno(STDOUT)) {
		    open(HIDE_STDOUT, '>&STDOUT')
					    if !defined fileno(HIDE_STDOUT);
		    close(STDOUT);
		}
	    } elsif ($state =~ /^ON$/i) {
		open(STDOUT, '>&HIDE_STDOUT');
	    } else {
		if (defined fileno(STDOUT)) {
		    open(HIDE_STDOUT, '>&STDOUT')
					    if !defined fileno(HIDE_STDOUT);
		    open(STDOUT, $state) || warn "$state: $!\n";
		}
	    }
	} elsif ($stream eq 'STDERR') {
	    if ($state =~ /^OFF$/i) {
		if (defined fileno(STDERR)) {
		    open(HIDE_STDERR, '>&STDERR')
					    if !defined fileno(HIDE_STDERR);
		    close(STDERR);
		}
	    } elsif ($state =~ /^ON$/i) {
		open(STDERR, '>&HIDE_STDERR');
	    } else {
		if (defined fileno(STDERR)) {
		    open(HIDE_STDERR, '>&STDERR')
					    if !defined fileno(HIDE_STDERR);
		    open(STDERR, $state) || warn "$state: $!\n";
		}
	    }
	}
    }
}

# Called like this "sendmsg([], $subject, @body_of_message)".
# I.e. a ref to a list of email addresses followed by a string
# scalar containing the subject. Remaining parameters are used
# as the body of the message. Returns true on successful delivery
# of msg to the MTA.
sub sendmsg {
    my($r_to, $subj, @body) = @_;
    # If no mailto list, no mail.
    return 1 unless @$r_to;

    # Only drag Net::SMTP in at runtime since it's not core perl.
    eval { require Net::SMTP };
    if (! $@) {
	my $name = $ENV{CLEARCASE_USER} || $ENV{USERNAME} || $ENV{LOGNAME};
	my $smtp;
	eval { $smtp = Net::SMTP->new };
	if ($smtp) {
	    local $^W = 0; # hide a spurious warning from deep in Net::SMTP
	    $smtp->mail($name) &&
		$smtp->to(@$r_to, {SkipBad => 1}) &&
		$smtp->data() &&
		$smtp->datasend("To: @$r_to\n") &&
		$smtp->datasend("Subject: $subj\n") &&
		$smtp->datasend(join(' ', 'X-Mailer:',__PACKAGE__,$VERSION)) &&
		$smtp->datasend("\n") &&
		$smtp->datasend(@body) &&
		$smtp->dataend() &&
		$smtp->quit &&
		return 1;	# succeeded, so return
	}
    }

    # If Net::SMTP isn't installed or didn't work, try notify.exe
    my $nexe = MSWIN() ? 'notify' : '/usr/atria/bin/notify';
    my $notify = qq($nexe -l triggers -s "$subj" ) .
					    join(' ', map {qq("$_")} @$r_to);
    if (open(NOTIFY, "| $notify")) {
	print NOTIFY @body;
	return close(NOTIFY);
    }
    return 0;	# failure
}

# A private wrapper over sendmsg() to reformat the subj/msg
# appropriately for error message captures.
sub _automail {
    return 0 if defined $ENV{CLEARCASE_CLEARPROMPT_NO_SENDMSG};
    my $type = shift;
    return unless exists $MailTo{$type} && $MailTo{$type};
    my $addrs = $MailTo{$type};
    my $subj = shift;
    # We don't need Sys::Hostname except in this situation, so ...
    eval { require Sys::Hostname; };
    $subj .= ' on ' . Sys::Hostname::hostname() unless $@;
    $subj .= ' via ClearCase::ClearPrompt';
    sendmsg($addrs, $subj, @_);
}

# Warning: significant hackery here. Basically, normal-looking symbol
# names are passed on to the Exporter import method as usual, whereas
# names of the form /WORD or +WORD or +WORD= are commands which
# cause special behavior within this routine. All commands start with
# '/', such as /TRIGGERSERIES and /ENV. Captures start with '+' and
# include +{CAPTURE,ERRORS,WARN,DIE,STDOUT,STDERR}. If the capture
# name has a list of users attached, eg "+STDERR=user1,user2,..",
# the captured messages are sent via email to the specified users.
# Use +CAPTURE= to email messages from all channels to .
## Apologies to anyone trying to read this ... it's a real mess, due
## mostly to my attempts to stay compatible with earler versions which
## may not have involved the best design decisions.
my($tmpout, $tmperr);	# these must be here for scoping reasons
sub import {
    # First remember the entire parameter list.
    my @p = @_;

    # Then separate it into "normal-looking" symbols to export into
    # caller's namespace, "captures" which describe channels we need
    # to arrange to capture here, and "commands" to deal with otherwise.
    # Also, provide our own implementation of export tags for qw(:all).
    # I'd prefer not to support that any more but do for back compat.
    my %exports = map { $_ => 1 } grep !m%^[+/:]%, @p;
    my %tags = map {substr($_, 1) => 1} grep m%^:%, @p;
    my %caps = map {m%^.(\w+)=?(.*)%; $1 => $2} grep m%^\+%, @p;
    my %cmds = map {m%^.(\w+)%; $1 => 1} grep m%^/%, @p;

    # Allow trigger series stashing to be turned on at import time,
    # but let the EV override. We allow '+TRIGGERSERIES' for
    # compatibility but '/TRIGGERSERIES' is preferred.
    if (exists($cmds{TRIGGERSERIES}) || exists($caps{TRIGGERSERIES})) {
	$cmds{TRIGGERSERIES} ||= $caps{TRIGGERSERIES};
	delete $caps{TRIGGERSERIES};
	$ClearCase::ClearPrompt::TriggerSeries = 1
			if !exists($ENV{CLEARCASE_CLEARPROMPT_TRIGGERSERIES});
    }

    # If requested to via '/ENV', modify all CLEARCASE_* EV's which
    # use back (\) slashes such that they use forward (/) slashes
    # instead, assuming that these will refer to pathnames or parts
    # of pathnames, perhaps in MVFS space (e.g. CLEARCASE_VERSION_ID).
    if (MSWIN() && exists($cmds{ENV})) {
	for (keys %ENV) {
	    $ENV{$_} =~ s%\\%/%g if m%^CLEARCASE_%;
	}
    }

    # The user may request via /DEBUG that the script (typically a trigger)
    # be rerun in debug mode. See POD.
    rerun_in_debug_mode() if exists($cmds{DEBUG});

    # The user may request via /SHELL that the script (typically a trigger)
    # fork an interactive shell so its runtime env can be explored.
    dbg_shell() if exists($cmds{SHELL});

    # Allow this EV to override the capture list.
    if ($ENV{CLEARCASE_CLEARPROMPT_CAPTURE_LIST}) {
	@p = split /\s+/, $ENV{CLEARCASE_CLEARPROMPT_CAPTURE_LIST};
	%caps = map {m%^.(\w+)=?(.*)%; $1 => $2} grep /^\+/, @p;
	for (split /\s+/, @p) {
	    m%^.(\w+)=?(.*)%;
	    $caps{$1} = $2;
	}
    }

    # Now divide capture requests into those for dialog boxes and
    # those for mailings.
    %Dialogs  = map {substr($_, 1) => 1} grep /^\+\w+$/, @p;
    %Mailings = map {m%^.(\w+)=(.*)%; $1 => $2 } grep /^\+\w+=/, @p;

    # If :tags were requested, map them to their predefined export lists.
    for (keys %tags) {
	my $tag = $_;
	next unless $EXPORT_TAGS{$tag};
	for (@{$EXPORT_TAGS{$tag}}) {
	    $exports{$_} = 1;
	}
    }

    # Export the die func if its corresponding channel was requested.
    $exports{'die'} = 1 if exists($caps{DIE}) ||
				exists($caps{CAPTURE}) || exists($caps{ERRORS});

    # Set up the override hook for warn() if requested.
    $SIG{__WARN__} = \&cpwarn if exists($caps{WARN}) ||
				exists($caps{CAPTURE}) || exists($caps{ERRORS});

    # Export the non-cmd symbols, which may include die().
    my @shares = grep {!/:/} keys %exports;
    if ($] <= 5.001) {
	# This weird hackery needed for ccperl (5.001) ...
	my $caller = caller;
	$caller = 'main' if $caller eq 'DB';	# hack for ccperl -d bug
	for (@shares) {
	    if (s/^(\W)//) {
		eval "*{$caller\::$_} = \\$1$_";
	    } else {
		*{"$caller\::$_"} = \&$_;
	    }
	}
    } else {
	# ... and this "normal" hackery is for modern perls.
	__PACKAGE__->export_to_level(1, $p[0], @shares);
    }

    # +CAPTURE grabs all forms of output while +ERRORS grabs only error
    # forms (meaning everything but stdout). NOTE: we must be very careful
    # about the fact that there may be keys which EXIST but whose
    # values are UNDEFINED.
    if (exists($Dialogs{CAPTURE})) {
	$Dialogs{WARN}		||= $Dialogs{CAPTURE};
	$Dialogs{DIE}		||= $Dialogs{CAPTURE};
	$Dialogs{STDERR}	||= $Dialogs{CAPTURE};
	$Dialogs{STDOUT}	||= $Dialogs{CAPTURE};
	delete $Dialogs{CAPTURE};
    } elsif (exists($Dialogs{ERRORS})) {
	$Dialogs{WARN}		||= $Dialogs{ERRORS};
	$Dialogs{DIE}		||= $Dialogs{ERRORS};
	$Dialogs{STDERR}	||= $Dialogs{ERRORS};
	delete $Dialogs{ERRORS};
    }
    if (exists($Mailings{CAPTURE})) {
	$Mailings{WARN}		||= $Mailings{CAPTURE};
	$Mailings{DIE}		||= $Mailings{CAPTURE};
	$Mailings{STDERR}	||= $Mailings{CAPTURE};
	$Mailings{STDOUT}	||= $Mailings{CAPTURE};
	delete $Mailings{CAPTURE};
    } elsif (exists($Mailings{ERRORS})) {
	$Mailings{WARN}		||= $Mailings{ERRORS};
	$Mailings{DIE}		||= $Mailings{ERRORS};
	$Mailings{STDERR}	||= $Mailings{ERRORS};
	delete $Mailings{ERRORS};
    }

    # Set up the mailing lists for each channel as requested.
    $MailTo{WARN}	= [split /,/, $Mailings{WARN}]   if $Mailings{WARN};
    $MailTo{DIE}	= [split /,/, $Mailings{DIE}]    if $Mailings{DIE};
    $MailTo{STDOUT}	= [split /,/, $Mailings{STDOUT}] if $Mailings{STDOUT};
    $MailTo{STDERR}	= [split /,/, $Mailings{STDERR}] if $Mailings{STDERR};
    $MailTo{PROMPT}	= [split /,/, $Mailings{PROMPT}] if $Mailings{PROMPT};

    # Last, handle generic stdout and stderr unless the caller asks us not to.
    if (exists($caps{STDOUT}) || exists($caps{STDERR})) {
	$tmpout = tempname('stdout');
	$tmperr = tempname('stderr');

	# Connect stdout and stderr to temp files for later use in END {}.
	if (exists($caps{STDOUT}) && ($ENV{ATRIA_FORCE_GUI} || $caps{STDOUT})) {
	    open(HOLDOUT, '>&STDOUT');
	    open(STDOUT, ">$tmpout") || warn "$tmpout: $!";
	}
	if (exists($caps{STDERR}) && ($ENV{ATRIA_FORCE_GUI} || $caps{STDERR})) {
	    open(HOLDERR, '>&STDERR');
	    open(STDERR, ">$tmperr") || warn "$tmperr: $!";
	}

	# After program finishes, collect any stdout/stderr and display
	# with clearprompt and/or mail it out.
	sub endfunc {
	    # retain original exit code on stack
	    my $rc = $?;
	    local $?;

	    # Restore stdout and stderr to their original fd's.
	    if (defined fileno HOLDOUT) {
		open(STDOUT, '>&HOLDOUT');
		close(HOLDOUT);
	    }
	    if (defined fileno HOLDERR) {
		open(STDERR, '>&HOLDERR');
		close(HOLDERR);
	    }

	    # Then display any stdout we captured in a dialog box.
	    if (defined($tmpout) && -e $tmpout) {
		open(OUT, $tmpout) || warn "$prog: $tmpout: $!";
		my @msg = ;
		close(OUT);
		if (@msg) {
		    _automail('STDOUT', "Stdout from $prog", @msg);
		    if ($Dialogs{STDOUT}) {
			my $t = "STDOUT\n\n @msg";
			clearprompt(qw(proceed -type o -mask p -pref -pro), $t);
		    }
		}
		if (!$ENV{CLEARCASE_CLEARPROMPT_KEEP_CAPTURE}) {
		    # On Windows, we can't unlink this tempfile while
		    # any asynchronous dialog boxes are still on the
		    # screen due to threading/locking design, so we
		    # give the user some time to read & close them.
		    if (MSWIN()) {
			system(1, qq($^X -e "sleep 30; unlink '$tmpout'"));
		    } else {
			unlink($tmpout) || print "$prog: $tmpout: $!\n";
		    }
		}
	    }
	    # Same as above but for stderr.
	    if (defined($tmperr) && -e $tmperr) {
		my @msg;
		{
		    open(ERR, $tmperr) || warn "$prog: $tmperr: $!";
		    local $^W = 0; #  gives bogus error with AS build 623
		    @msg = ;
		    close(ERR);
		}
		if (@msg) {
		    _automail('STDERR', "Stderr from $prog", @msg);
		    if ($Dialogs{STDERR}) {
			my $t = "STDERR\n\n @msg";
			clearprompt(qw(proceed -type o -mask p -pref -pro), $t);
		    }
		}
		if (!$ENV{CLEARCASE_CLEARPROMPT_KEEP_CAPTURE}) {
		    if (MSWIN()) {
			system(1, qq($^X -e "sleep 30; unlink '$tmperr'"));
		    } else {
			unlink($tmperr) || print "$prog: $tmperr: $!\n";
		    }
		}
	    }
	};
	eval "END { endfunc(); }";
    }
}

# This is a pseudo warn() func which is called via the $SIG{__WARN__} hook.
sub cpwarn {
    my @msg = @_;
    # always show line numbers if this dbg flag set
    if ($ENV{CLEARCASE_CLEARPROMPT_SHOW_LINENO}) {
	my($file, $line) = (caller)[1,2];
	chomp $msg[-1];
	push(@msg, " at $file line $line.\n");
    }
    _automail('WARN', "Warning from $prog", @msg);
    if ($ENV{ATRIA_FORCE_GUI} && $Dialogs{WARN}) {
	clearprompt(qw(proceed -type w -mask p -pref -pro), "WARNING\n\n@msg");
	return undef; 	# to keep clearprompt() in void context
    } else {
	warn @msg;
    }
}

# A pseudo die() which can be made to override the caller's builtin.
sub die {
    my @msg = @_;
    # always show line numbers if this dbg flag set
    if ($ENV{CLEARCASE_CLEARPROMPT_SHOW_LINENO}) {
	my($file, $line) = (caller)[1,2];
	chomp $msg[-1];
	push(@msg, " at $file line $line.\n");
    }
    _automail('DIE', "Error from $prog", @msg);
    if ($ENV{ATRIA_FORCE_GUI} && $Dialogs{DIE}) {
	clearprompt(qw(proceed -type e -mask p -pref -pro), "ERROR\n\n@msg");
	exit $! || $?>>8 || 255;	# suppress the msg to stderr
    } else {
	require Carp;
	CORE::die Carp::shortmess(@_);

    }
}

1;

__END__