view release on metacpan or  search on metacpan

ClearPrompt.pm  view on Meta::CPAN

# 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 <file> 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 = <OUTFILE>;
		$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;

ClearPrompt.pm  view on Meta::CPAN

	    }

	    # Then display any stdout we captured in a dialog box.
	    if (defined($tmpout) && -e $tmpout) {
		open(OUT, $tmpout) || warn "$prog: $tmpout: $!";
		my @msg = <OUT>;
		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; # <ERR> gives bogus error with AS build 623
		    @msg = <ERR>;
		    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__

=head1 NAME

ClearCase::ClearPrompt - Handle clearprompt in a portable, convenient way

=head1 SYNOPSIS

 use ClearCase::ClearPrompt qw(clearprompt);

 # Boolean usage
 my $rc = clearprompt(qw(yes_no -mask y,n -type ok -prompt), 'Well?');

 # Returns text into specified variable (context sensitive).
 my $txt = clearprompt(qw(text -pref -pro), 'Enter text data here: ');

 # Asynchronous usage - show dialog box and continue
 clearprompt(qw(proceed -mask p -type ok -prompt), "You said: $txt");

 # Trigger series (record/replay responses for multiple elements)
 use ClearCase::ClearPrompt qw(clearprompt /TRIGGERSERIES);
 my $txt = clearprompt(qw(text -pref -pro), 'Response for all elems: ');

 # Clean up environment on Windows to use /-style paths:
 use ClearCase::ClearPrompt qw(/ENV);

 # Cause the program to run in the debugger, even in a GUI environment:
 use ClearCase::ClearPrompt qw(/DEBUG);

 # Automatically divert trigger error msgs to clearprompt dialogs
 use ClearCase::ClearPrompt qw(+ERRORS);

 # As above but send error msgs via email instead to user1 and user2
 use ClearCase::ClearPrompt qw(+ERRORS=user1,user2);

 # As above but send msgs to the current user
 use ClearCase::ClearPrompt '+ERRORS=' . ($ENV{LOGNAME} || $ENV{USERNAME});

 # Prompt for a directory (not supported natively by clearprompt cmd)
 use ClearCase::ClearPrompt qw(clearprompt_dir);
 my $dir = clearprompt_dir('/tmp', "Please choose a directory");

=head1 DESCRIPTION