File Coverage

blib/lib/ClearCase/Argv.pm

Criterion	Covered	Total	%
statement	48	547	8.7
branch	4	376	1.0
condition	1	153	0.6
subroutine	15	48	31.2
pod	3	22	13.6
total	71	1146	6.2

package ClearCase::Argv;

$VERSION = '1.54';

use Argv 1.28;

use constant MSWIN	=> $^O =~ /MSWin|Windows_NT/i ? 1 : 0;
use constant CYGWIN	=> $^O =~ /cygwin/i ? 1 : 0;

my $NUL = MSWIN ? 'NUL' : '/dev/null';

@ISA = qw(Argv);
%EXPORT_TAGS = ( 'functional' => [ qw(ctsystem ctexec ctqx ctqv ctpipe chdir) ] );
@EXPORT_OK = (@{$EXPORT_TAGS{functional}});

*AUTOLOAD = \&Argv::AUTOLOAD;

use strict;

my $class = __PACKAGE__;
if (CYGWIN) {
    require Text::ParseWords;
    $class->inpathnorm(1);
    $class->outpathnorm(1);
}
my %pidcount;
END {
  my $ret = $?;
  ClearCase::Argv->ipc(0); #Kill any remaining coprocess
  $? |= $ret;
}
# For programming purposes we can't allow per-user preferences.
if ($ENV{CLEARCASE_PROFILE}) {
    $ENV{_CLEARCASE_PROFILE} = $ENV{CLEARCASE_PROFILE};
    delete $ENV{CLEARCASE_PROFILE};
}

# Allow EV's setting class data in the derived class to override the
# base class's defaults.There's probably a better way to code this.
for (grep !/^_/, keys %Argv::Argv) {
    (my $ev = uc(join('_', __PACKAGE__, $_))) =~ s%::%_%g;
    $Argv::Argv{$_} = $ENV{$ev} if defined $ENV{$ev};
}

my @ct = ('cleartool');

# Attempt to find the definitive ClearCase bin path at startup. Don't
# try excruciatingly hard, it would take unwarranted time. And don't
# do so at all if running setuid or as root. If this doesn't work,
# the path can be set explicitly via the 'cleartool_path' class method.
if (!MSWIN && ($< == 0 || $< != $>  || !grep{$_}@ENV{qw(PATH ATRIAHOME)})) {
    # running as root, or setuid, even if the same user as the suid one...
    @ct = ('/opt/rational/clearcase/bin/cleartool');
} elsif ($ENV{PATH} !~ m%\W(atria|ClearCase)\Wbin\b%i) {
    if (!MSWIN) {
	my $abin = $ENV{ATRIAHOME} ? "$ENV{ATRIAHOME}/bin" : '/usr/atria/bin';
	$ENV{PATH} .= ":$abin" if -d $abin && $ENV{PATH} !~ m%/atria/bin%;
    } else {
	local $^W = 0;
	for (   ($ENV{ATRIAHOME} || '') . "/bin",
		'C:/Program Files/Rational/ClearCase/bin',
		'D:/Program Files/Rational/ClearCase/bin',
		'C:/atria/bin',
		'D:/atria/bin') {
	    if (-d $_ && $ENV{PATH} !~ m%$_%) {
		$ENV{PATH} .= ";$_";
		last;
	    }
	}
    }
}

# Class method to get/set the location of 'cleartool'.
sub cleartool_path {
    my $self = shift;
    if (ref $self and $self->{CT}) {
	$self->ct(@_) if @_;
	return @{$self->ct};
    } else {
	@ct = @_ if @_;
	return @ct;
    }
}
*find_cleartool = \&cleartool_path;  # backward compatibility

sub perlscript {
    my $self = shift;
    for (@{$self->{CT}}) {
	next unless open my $fd, q(<), $_;
	my $line = <$fd>;
	close $fd;
	return 1 if $line =~ m%^(#!|\@rem ).*\bperl\b%i;
    }
    return 0;
}
sub ct {
    my $self = shift;
    if (ref $self) {
	if (@_) {
	    if ($self->ipc) {
	        # servicing attrs after raw copy: the pid count was not
	        # incremented yet, so we cannot call ipc(0)
		delete $self->{IPC};
		$self->{CT} = ref($_[0])? $_[0] : [@_];
		$self->ipc(1);
	    } else {
		$self->{CT} = ref($_[0])? $_[0] : [@_];
	    }
	    $self->{WRAPPER}++ if $self->perlscript;
	    return defined(wantarray)? $self : undef;
	} else {
	    return $self->{CT}? @{$self->{CT}} : @ct;
	}
    } else {
	return cleartool_path;
    }
}
# Override of base-class method to change a prog value of 'foo' into
# qw(cleartool foo). If the value is already an array or array ref
# leave it alone. Same thing if the 1st word contains /cleartool/
# or is an absolute path.
sub prog {
    my $self = shift;
    return $self->SUPER::prog unless @_;
    my $prg = shift;
    if (@_ || ref($prg) || $prg =~ m%^/|^\S*(?:clear|multi)tool%
	                                                    || $self->ctcmd) {
	return $self->SUPER::prog($prg, @_);
    } else {
	require Text::ParseWords;
	my @prg = map { s/^'(.*)'$/$1/ || s/^"(.*)"$/$1/; $_ }
	                         Text::ParseWords::parse_line('\s+', 1, $prg);
	return $self->SUPER::prog([$self->ct, @prg], @_);
    }
}

# Overridden to allow for alternate execution modes.
sub exec {
    $class->new(@_)->exec if !ref($_[0]) || ref($_[0]) eq 'HASH';
    my $self = shift;
    if ($self->ctcmd) {
	exit $self->system(@_) >> 8;
    } elsif ($self->ipc) {
	my $rc = $self->system(@_);
	$rc ||= $self->ipc(0);
	exit($rc);
    } else {
	return $self->SUPER::exec(@_);
    }
}

# Overridden to allow for alternate execution modes.
sub system {
    return $class->new(@_)->system if !ref($_[0]) || ref($_[0]) eq 'HASH';
    my $self = shift;
    my @rargs = @_;
    $self->_cvt_input_cw() if CYGWIN;

    if (!$self->ctcmd && !$self->ipc) {
        if (CYGWIN) {
	    my @ret = $self->SUPER::qv(@rargs);
	    $self->unixpath(@ret) unless $self->{WRAPPER};
	    print join("", @ret) if @ret;
	    return $?;
	} else {
	    return $self->SUPER::system(@rargs);
	}
    }

    my $envp = $self->envp;
    my($ifd, $ofd, $efd) = ($self->stdin, $self->stdout, $self->stderr);
    $self->args($self->glob) if $self->autoglob;
    my @prog = @{$self->{AV_PROG}};
    shift(@prog) while grep m%(?:clear|multi)tool%, @prog;
    my @opts = $self->_sets2opts(@_);
    my @args = @{$self->{AV_ARGS}};
    my @cmd = (@prog, @opts, @args);
    my $dbg = $self->dbglevel;
    $self->_addstats("cleartool @prog", scalar @args) if %Argv::Summary;
    $self->warning("cannot close stdin of child process") if $ifd;
    if ($self->noexec && !$self->_read_only) {
	$self->_dbg($dbg, '-', \*STDERR, @cmd);
	return 0;
    }
    open(_O, '>&STDOUT');
    open(_E, '>&STDERR');
    my($outplace, $errplace) = (0, 0);
    if ($self->quiet) {
	$outplace = 1;
    } elsif ($ofd == 2) {
	open(STDOUT, '>&STDERR') || warn "Can't dup stdout";
    } elsif ($ofd !~ m%^\d*$%) {
	open(STDOUT, $ofd) || warn "$ofd: $!";
    } else {
	warn "Warning: illegal value '$ofd' for stdout" if $ofd > 2;
        if ($ofd == 0) {
	    $outplace = -1;
	    open(STDOUT, ">$NUL") if $self->ipc();
	}
    }
    $self->_dbg($dbg, '+>', \*STDERR, @cmd) if $dbg && $self->ctcmd;
    if ($efd == 1) {
	open(STDERR, '>&STDOUT') || warn "Can't dup stderr";
    } elsif ($efd !~ m%^\d*$%) {
	open(STDERR, $efd) || warn "$efd: $!";
    } else {
	warn "Warning: illegal value '$efd' for stderr" if $efd > 2;
	$errplace = -1 if $efd == 0;
    }
    my $rc = 0;
    if ($self->ctcmd) {
	my $ctc = ClearCase::CtCmd->new(outfunc=>$outplace, errfunc=>$errplace);
	if ($envp) {
	    local %ENV = %$envp;
	    $ctc->exec(@cmd);
	} else {
	    $ctc->exec(@cmd);
	}
	$rc = $ctc->status;
    } else {
        if ($cmd[0] eq 'setview') {
	    if ($cmd[1] eq '-exec') {
		return $self->stderr($efd)->SUPER::system;
	    }
	    $self->ipc(0);
	    my @data;
	    $self->ipc($cmd[1], \@data);
	    if (@data) {
		if ($efd == 2) {
		    print STDERR @data;
		} elsif ($efd == 1) {
		    print STDOUT @data;
		}
		my @err = grep !/^cleartool: Warning:/, @data;
		delete $self->{IPC} if @err; #dtor would send 'exit' to defunct
		return scalar @err;
	    } else {
	        return 0;
	    }
	}
        $rc = $self->_ipc_cmd(undef, $ofd, $efd, @cmd);
    }
    open(STDOUT, '>&_O'); close(_O);
    open(STDERR, '>&_E'); close(_E);
    print STDERR "+ (\$? == $?)\n" if $dbg > 1;
    $self->fail($self->syfail) if $rc;
    $? = $rc;
    return $rc;
}

# Overridden to allow for alternate execution modes.
sub qx { # } --for emacs CPerl mode, as 'qx' is a keyword
    return $class->new(@_)->qx if !ref($_[0]) || ref($_[0]) eq 'HASH';
    my $self = shift;
    my @rargs = @_;
    $self->_cvt_input_cw() if CYGWIN;

    unless ($self->ctcmd || $self->ipc) {
        my @ret = $self->SUPER::qx(@rargs);
        if (CYGWIN and !$self->{WRAPPER}) {
	    $self->unixpath(@ret);
        }
        return wantarray? @ret : join '', @ret;
    }

    my($rc, $data, $errors);
    my $dbg = $self->dbglevel;

    my $envp = $self->envp;
    my($ifd, $ofd, $efd) = ($self->stdin, $self->stdout, $self->stderr);
    $self->args($self->glob) if $self->autoglob;
    my @prog = @{$self->{AV_PROG}};
    shift(@prog) while grep m%(?:clear|multi)tool%, @prog;
    my @opts = $self->_sets2opts(@_);
    my @args = @{$self->{AV_ARGS}};
    my @cmd = (@prog, @opts, @args);
    $self->_addstats("cleartool @prog", scalar @args) if %Argv::Summary;
    $self->warning("cannot close stdin of child process") if $ifd;
    if ($self->noexec && !$self->_read_only) {
	$self->_dbg($dbg, '-', \*STDERR, @cmd);
	return 0;
    }
    $self->_dbg($dbg, '+>', \*STDERR, @cmd) if $dbg && $self->ctcmd;
    if ($self->ctcmd) {
	my $ctc = ClearCase::CtCmd->new;
	if ($envp) {
	    local %ENV = %$envp;
	    ($rc, $data, $errors) = $ctc->exec(@cmd);
	} else {
	    ($rc, $data, $errors) = $ctc->exec(@cmd);
	}
	$data ||= '';
         if ($data) {
             if (!$ofd) {
                 $data = '';
             } elsif ($ofd == 2) {
                 print STDERR $data;
             }
         }
	if ($errors) {
	    if ($efd == 1) {
	        $data .= $errors;
	    } elsif ($efd == 2) {
	        print STDERR $errors;
	    }
	}
	print STDERR "+ (\$? == $?)\n" if $dbg > 1;
	if (wantarray) {
	    my @data = split /\n/, $data;
	    if (! $self->autochomp) {
		for (@data) { $_ .= "\n" }
	    }
	    $self->unixpath(@data) if MSWIN && $self->outpathnorm;
	    print STDERR map {"+ <- $_"} @data if @data && $dbg >= 2;
	    if ($rc) {
		$self->lastresults($rc, @data);
		$self->fail($self->qxfail);
	    }
	    $? = $rc;
	    return @data;
	} else {
	    chomp($data) if $self->autochomp;
	    $self->unixpath($data) if MSWIN && $self->outpathnorm;
	    print STDERR "+ <- $data" if $data && $dbg >= 2;
	    if ($rc) {
		$self->lastresults($rc, $data);
		$self->fail($self->qxfail);
	    }
	    $? = $rc;
	    return $data;
	}
    } else {
        if ($cmd[0] eq 'setview') {
	    if ($cmd[1] eq '-exec') {
		my $ret = $self->stderr($efd)->SUPER::qx;
		chomp($ret) if $self->autochomp;
		return wantarray? split(/\n/, $ret) : $ret;
	    }
            $self->ipc(0);
            my @data;
            $self->ipc($cmd[1], \@data);
            if ($efd == 2) {
                print STDERR @data;
            } elsif ($efd == 1) {
                return wantarray? @data : join '', @data;
            }
            return '';
        }
	my @data = ();
	$rc = $self->_ipc_cmd(\@data, $ofd, $efd, @cmd);
	print STDERR "+ (\$? == $?)\n" if $dbg > 1;
	if (wantarray) {
	    chomp(@data) if $self->autochomp;
	    $self->unixpath(@data) if MSWIN && $self->outpathnorm;
	    if ($rc) {
		$self->lastresults($rc, @data);
		$self->fail($self->qxfail);
	    }
	    $? = $rc;
	    return @data;
	} else {
	    my $data = join '', @data;
	    chomp($data) if $self->autochomp;
	    $self->unixpath($data) if MSWIN && $self->outpathnorm;
	    if ($rc) {
		$self->lastresults($rc, $data);
		$self->fail($self->qxfail);
	    }
	    $? = $rc;
	    return $data;
	}
    }
}

# Overridden to allow special handling for CtCmd and IPC modes.
sub pipe {
    return $class->new(@_)->pipe if !ref($_[0]) || ref($_[0]) eq 'HASH';

    my $self = shift;
    my $mode;
    if ($self->ctcmd) {
	$mode = 'CtCmd';
    } elsif ($self->ipc) {
        $mode = 'IPC';
    }
    if ($mode) {
	my $otherSelf = $self->clone();
	$self->warning("$mode usage incompatible with pipe - temporarily" .
			 " reverting to plain cleartool") if $self->dbglevel;
	if ($mode eq 'CtCmd') {
	    $otherSelf->ctcmd(0);
	    my @prg = $otherSelf->prog; #Depends on the exact invocation path
	    $otherSelf->prog($self->ct, @prg)
	                             unless grep m%(?:clear|multi)tool%, @prg;
	} else {
	    $otherSelf->ipc(0);
	}
	return $otherSelf->SUPER::pipe(@_);
    } else {
	return $self->SUPER::pipe(@_);
    }
}

# Normalizes a path to Unix style (forward slashes).
sub unixpath {
    my $self = shift;
    if (CYGWIN) {
        no strict 'subs';
	for my $line (@_) {
	    my $nl = chomp $line;
	    my $bs = $line =~ s/\\$//;
	    $line =~ s%\r$%%;
	    my @chars = split//,$line;
	    my $odd = (((grep/'/,@chars) % 2) || ((grep/"/,@chars) % 2));
	    my @bit = $odd? split/(\s+)/,$line
	      : Text::ParseWords::parse_line('\s+', 'delimiters', $line);
	    map {
	        s%\\%/%g if m%(?:^(?:"|[\w/.-]*)|\@)\\%;
		if (m%^(vob|[A-Za-z]):%) {
		  $_ = Cygwin::win_to_posix_path($_);
		} else {
		  s%^//view%/view%;
		}
	    } grep { $_ && m%\S% } @bit;
	    $line = join '', grep {defined($_)} @bit;
	    $line .= '\\' if $bs;
	    $line .= "\n" if $nl;
	}
    } else {
        $self->SUPER::unixpath(@_);
	# Now apply CC-specific, @@-sensitive transforms to partial lines.
	for my $line (@_) {
	    my $fixed = '';
	    for (split(m%(\S+@@\S*)%, $line)) {
	        s%\\%/%g if m%^.*?\S+@@%;
		$fixed .= $_;
	    }
	    $line = $fixed;
	}
    }
}

# Attaches to or detaches from a CtCmd object for execution.
sub ctcmd {
    my $self = shift;	# this might be an instance or a classname
    my $level = shift;
    $level = 2 if !defined($level) && !defined(wantarray);
    if ($level) {
        if ($self->ipc && !CYGWIN) {
	    $self->ipc(0);	# shut the ipc down
	}
	eval { require ClearCase::CtCmd };
	if ($@) {
	    my $msg = $@;
	    if ($level == 2 && $msg =~ m%^(Can't locate \S+)%) {
		$msg = $1;
	    } elsif ($level > 2) {
		die("Error: $msg");
	    }
	    if ($level == 1 || $level == 2) {
		# On Windows, if the real ClearCase::CtCmd is missing hack
		# in our own version that uses CAL directly.
		if (MSWIN) {
		    eval { require Win32::OLE };
		    if ($@) {
			warn("Warning: $msg\n") if $level == 2;
			return undef;
		    } else {
			warn("Warning: $msg, using CAL instead\n")
			    if $level == 2;
			*ClearCase::CtCmd::new = \&_ctcmd_new;
			*ClearCase::CtCmd::status = \&_ctcmd_status;
			*ClearCase::CtCmd::exec = \&_ctcmd_cmd2cal;
			*ClearCase::CtCmd::cleartool = \&_ctcmd_cmd2cal;
			$ClearCase::CtCmd::VERSION = '1.01';
			Win32::OLE->Option(Warn => 0);
		    }
		} else {
		    my $rep = CYGWIN? "ipc" : "fork/exec";
		    warn("Warning: $msg, using $rep instead\n") if $level == 2;
		    return undef;
		}
	    } else {
	      no strict 'refs';
	      $self->{CCAV_CTCMD} = 0;
	      return undef;
	    }
	}
    }
    no strict 'refs';		# because $self may be a symbolic hash ref
    if (defined($level)) {
	if ($level) {
	    ClearCase::CtCmd->VERSION(1.01) if $ClearCase::CtCmd::VERSION;
	    $self->{CCAV_CTCMD} = 1;
	    # If setting a class attribute, export it to the
	    # env in case we fork a child using ClearCase::Argv.
	    ## NOT SURE WE REALLY WANT THIS IN THIS CASE ...??
	    ## $ENV{CLEARCASE_ARGV_CTCMD} = $self->{CCAV_CTCMD} if !ref($self);
	    return $self;
	} else {					# close up shop
	    delete $self->{CCAV_CTCMD} if exists $self->{CCAV_CTCMD};
	    delete $ENV{CLEARCASE_ARGV_CTCMD}
				if $ENV{CLEARCASE_ARGV_CTCMD} && !ref($self);
	    return $self;
	}
    } else {
	if (!defined($self->{CCAV_CTCMD}) && !defined($class->{CCAV_CTCMD})) {
	    return $ENV{CLEARCASE_ARGV_CTCMD} ? $self : 0;
	}
	return ($self->{CCAV_CTCMD} || $class->{CCAV_CTCMD}) ? $self : undef;
    }
}

sub _ctcmd_new {
    my $object = shift;
    my $this = {};
    %$this = @_;
    bless $this, $object;
    $this->{'status'} = 0;
    return $this;
}

sub _ctcmd_status {
    my $this = shift;
    return $this->{'status'}
}

sub _ctcmd_cmd2cal {
    my $self = ref($_[0]) ? shift : undef;
    # It may make more sense to stash a copy of this object rather than
    # recreate it each time.
    my $ccct = Win32::OLE->new('ClearCase.ClearTool');
    # Turn list cmds into a quoted string.
    my $cmd = (@_ == 1) ? $_[0] : join(' ', map {"'$_'"} @_);
    # Send the actual command to CAL and get stdout returned.
    my $out = $ccct->CmdExec($cmd);
    # Must reap the return code first, then get stderr IFF retcode != 0.
    my $rc = int Win32::OLE->LastError;
    my $err = $rc ? Win32::OLE->LastError . "\n" : '';
    # Massage the output from CmdExec into cmdline-style format ...
    # Turn the literal CRLF sequence into \n for subsequent chomp/splits.
    for ($out, $err) {
	s/\015?\012/\n/g if $_;
    }
    # Strip the OLE verbosity from any error messages.
    if ($err) {
	$err =~ s%^OLE\s+exception.*%%;
	$err =~ s%^\s*%%s;
	$err =~ s%\s*Win32::OLE.*%\n%s;
    }
    $self->{'status'} = $rc if $self;
    my @results = $rc;
    if (defined($out)) {
        if ($self && exists($self->{outfunc}) && ($self->{outfunc} == 0)) {
	    print STDOUT $out;
        } else {
	    push(@results, $out);
        }
    } else {
        push(@results, q()); #Make sure $err will go into the 3rd slot
    }
    if ($self && exists($self->{errfunc}) && ($self->{errfunc} == 0)) {
	print STDERR $err;
    } else {
	push(@results, $err);
    }
    if (wantarray) {
	return @results;
    } else {
	$? = $rc if $rc;
	print STDERR $results[2] if defined($results[2]);
	return $results[1];
    }
}

# Starts or stops a cleartool coprocess.
sub ipc {
    my $self = shift;	# this might be an instance or a classname
    no strict 'refs';	# because $self may be a symbolic hash ref
    my $level = shift;
    my $output = shift;
    local $\ = '';	   # no extra newlines e.g. under perl -le ...
    if (defined($level) && !$level) {
	return 0 unless exists($self->{IPC});
	my $down = $self->{IPC}->{DOWN};
	my $pid = $self->{IPC}->{PID};
	delete $self->{IPC};
	return 0 if --$pidcount{$pid};
	# Send an explicit "exit" command and close up shop.
	print $down "exit\n";
	my $rc = close($down);
	waitpid($pid, 0);
	delete $pidcount{$pid};
	return $rc || $?;
    } elsif (!defined($level)) {
	return exists($self->{IPC}) ? $self : 0;
    }

    if ($self->ctcmd) {
	$self->ctcmd(0);	# shut down the CtCmd connection
    }
    if (exists($class->{IPC}) && $level =~ m%^\d+$%
	                                    && !$self->{CT} && !$class->{CT}
            || ($self->{CT} && $class->{CT} && $self->{CT} eq $class->{CT})) {
        if (($self ne $class) && !$self->ipc) {
	    ++$pidcount{$class->{IPC}->{PID}};
	    $self->{IPC}->{PID}  = $class->{IPC}->{PID};
	    $self->{IPC}->{DOWN} = $class->{IPC}->{DOWN};
	    $self->{IPC}->{BACK} = $class->{IPC}->{BACK};
	}
	return $self;
    }

    # This should never fail to load since it's built in.
    require IPC::Open3;

    # Dies on failure.
    my($down, $back);
    my $view = ($level =~ /^\d+$/) ? '' : $level;
    my @cmd = !$view ? ($self->ct, '-status')
      : ($self->ct, qw(setview -exec), join(' ', $self->ct, '-status'), $view);
    my $pid = IPC::Open3::open3($down, $back, undef, @cmd);

    # Set the "line discipline" to convert CRLF to \n.
    binmode $back, ':crlf';

    if ($view) {
      print $down "des -fmt '\\n' .\n";
      while ($_ = <$back>) {
	last if /^Command 1 returned status/;
	push @{$output}, $_ unless /^$/;
      }
    }

    $self->{IPC}->{DOWN} = $down;
    $self->{IPC}->{BACK} = $back;
    $self->{IPC}->{PID} = $pid;
    ++$pidcount{$pid};

    return $self;
}

sub _cw_map {
    use File::Basename;
    no warnings;
    for (@_) {
        next if s%^(vob:)?/cygdrive/([A-Za-z])%$1$2:%;
	next if s%^(vob:)?/view%$1//view%;
	if (m%^/[^/]%) {
	    my $p = dirname $_;
	    if ($p eq '/' && ! -r) {
	        s%^/%\\%; # case of vob tags
	    } elsif (-r $p) {
	        $_ = Cygwin::posix_to_win_path($_);
	    }
	}
    }
}

sub _cvt_input_cw {
    my $self = shift;
    return if $self->{WRAPPER};
    _cw_map @{$self->{AV_ARGS}};
    for my $o (values %{$self->{AV_OPTS}}) {
        _cw_map grep{$_}@{$o};
    }
}

# commands sent to ipc must be single line ones
sub _ipc_nl_in_cmt {
    my $r = shift;
    my ($i, $c, $v) = 0;
    for (@{$r}) {
        if (m%^-c(omment)?$%) {
	    $c = $i;
	} elsif (m%^-(nc|c[fq])%) {
	    last;
	} elsif ($c and $i == $c + 1) {
	    $v = $_ if m%\n%;
	    last;
	}
	$i++;
    }
    if ($v) {
        use File::Temp qw(tempfile);
        my ($fh,$cfile) = tempfile;
	print $fh $v;
	close $fh;
	splice @{$r} ,$c ,2 , ('-cfile', $cfile);
    }
}

sub _ipc_cmd {
    my $self = shift;
    my ($disposition, $stdout, $stderr, @cmd) = @_;
    local *_;
    local $\ = '';	   # no extra newlines e.g. under perl -le ...
    _ipc_nl_in_cmt(\@cmd);
    # Send the command to cleartool.
    my $qm = ((MSWIN || CYGWIN) && !$self->{WRAPPER})?
                                    sub { shift; s%\'%^'%g; return qq('$_'); }
                                  : sub { quotemeta shift };
    my $cmd = join(' ', map {
        m%^$|\s|[\[\]\(\)*"'?]% ?
	  (m%'% ?
	     (m%"% ?
		$qm->($_) : qq("$_"))
	       : qq('$_'))
	    : $_
    } grep {defined} @cmd);
    # Handle verbosity.
    my $dbg = $self->dbglevel;
    $self->_dbg($dbg, '=>', \*STDERR, $cmd) if $dbg;

    chomp $cmd;
    my $down = $self->{IPC}->{DOWN};
    print $down $cmd, "\n";

    # Supply custom comment on standard input if requested.
    if (exists $self->{IPC}->{COMMENT}) {
	my $input = $self->{IPC}->{COMMENT};
	print $down $input, "\n.\n";
	delete $self->{IPC}->{COMMENT};
    }
    my $man = ($self->{AV_PROG}->[1] eq 'man'); #Special case: errors ok
    my $diff = ($self->{AV_PROG}->[1] eq 'diff');
    my $manok; #Some man output already: no complete failure
    # Read back the results and get command status.
    my $rc = 0;
    my $back = $self->{IPC}->{BACK};
    while($_ = <$back>) {
        my ($last, $next, $err);
	my $out = *STDOUT;
	if (!$manok && m%^(?:clear|multi)tool.*?: (Error|Warning):%) {
	    if ($stderr) {
	        $out = *STDERR;
	        $err = 1;
	    } else {
	        $next = 1;
	    }
	} elsif (!$man && m%^Comments for %) {
	  if ($disposition) {
	    push(@$disposition, $_);
	  } else {
	    print $out $_;
	  }
	  while (<>) {
	        chomp;
		s%\r$%% if MSWIN;
		print $down "$_\n";
	        last if m%^\.$%;
	    }
	} elsif (s%^(.*)Command \d+ returned status (\d+)%$1%) {
	    $rc = $2 unless $rc;
	    chomp;
	    $_ ? $last = 1 : last;
	} elsif (!$manok && $man) {
	    $manok = 1;
	}
	print '+ <=', $_ if $_ && $dbg >= 2;
	$rc = 1 if $diff && !m%^Files are identical%;
	next if $next;
	$self->unixpath($_) if CYGWIN and !$self->{WRAPPER};
	if ($stdout || ($err && $stderr)) {
	    if ($disposition && (($err && $stderr == 1) || (!$err && $stdout == 1))) {
	        push(@$disposition, $_);
	    } else {
	        print $out $_;
	    }
	}
	last if $last;
    }
    return $rc;
}

sub fork_exec {
    my $self = shift;
    $self->ipc(0);
    $self->ctcmd(0);
}

sub exec_style {
    my $self = shift;
    my $style = shift;
    if ($style) {
	no strict 'subs';
	$self->$style(shift || 3);
    }
    if ($self->ctcmd) {
	return "CTCMD";
    } elsif ($self->ipc) {
	return "IPC";
    } else {
	return "FORK";
    }
}

sub _read_only {
    my $self = shift;
    if ($self->readonly =~ /^a/i) {	# a=automatic
	my @cmd = $self->prog;
	if ($cmd[-1] =~ m%^(ls|annotate|apropos|cat|des|diff|dospace|
			    file|getcache|getlog|help|host|man|pw|
			    setview|space)%x) {
	    return 1;
	} else {
	    return 0;
	}
    } else {
	return $self->SUPER::_read_only;
    }
}

# The cleartool command has quoting rules different from any system
# shell so we subclass the quoting method to deal with it. Not
# currently well tested with esoteric cmd lines such as mkattr.
## THIS STUFF IS REALLY COMPLEX WITH ALL THE PERMUTATIONS
## OF PLATFORMS, SUBCLASSES, SHELLS, AND APIs. WATCH OUT.
sub quote {
    my $self = shift;
    # Don't quote the 2nd word where @_ = ('cleartool', 'pwv -s');
    return @_ if @_ == 2;
    return $self->SUPER::quote(@_) if @_ > 2;
    # Ok, now we're looking at interactive-cleartool quoting ("man cleartool").
    if (!MSWIN && $self->ipc) {
	# Special case - extract multiline comments from the cmd line and
	# put them in the stdin stream when using UNIX co-process model.
	for (my $i=0; $i < $#_; $i++) {
	    if ($_[$i] eq '-c' && $_[$i+1] =~ m%\n%s) {
		$self->stdin("$_[$i+1]\n.");
		splice(@_, $i, 2, '-cq');
		last;
	    }
	}
    }
    # Single quotes aren't understood by the &*&#$ Windows shell
    # but cleartool gets them right so this quoting is simpler.
    my $inpathnorm = $self->inpathnorm;
    for (@_) {
        $_ = Cygwin::posix_to_win_path($_) if CYGWIN && m%^/%;
	# If requested, change / for \ in Windows file paths.
	s%/%\\%g if $inpathnorm;
	# Now quote embedded quotes ...
	s%'%\\'%g;
	# and then the entire string.
	$_ = qq('$_');
    }
    return @_;
}

# Hack - allow a comment to be registered here. The next command will
# see it with -c "comment" if in regular mode or with -cq and reading
# the comment from stdin if in ->ipc mode.
sub comment {
    my $self = shift;
    my $cmnt = join("\n", @_);
    my @prev = $self->opts;
    if ($self->ipc) {
	$self->opts('-cq', @prev) if !grep /^-cq/, @prev;
	$self->{IPC}->{COMMENT} = $cmnt;
    } else {
	$self->opts('-c', $cmnt, @prev) if !grep /^-c/, @prev;
    }
    return $self;
}

# Add -/ipc and -/ctcmd to list of supported attr-flags.
sub attropts {
    my $self = shift;
    return $self->SUPER::attropts(@_, qw(ipc ctcmd));
}

sub _chdir {
    my $self = shift; # this might be an instance or a classname
    my ($dir) = @_;
    chomp $dir;
    my $rc = CORE::chdir($dir);
    if ($self->ipc) {
        my $ctcd = ref($self) ? $self->clone : __PACKAGE__->new;
        $ctcd->stdout(0)->argv('cd', $dir)->system;
    }
    return $rc;
}

# Export our own functional interfaces as well.
sub ctsystem	{ return __PACKAGE__->new(@_)->system }
sub ctexec	{ return __PACKAGE__->new(@_)->exec }
sub ctqx	{ return __PACKAGE__->new(@_)->qx }
sub ctpipe	{ return __PACKAGE__->new(@_)->pipe }
sub chdir	{ return __PACKAGE__->_chdir(@_) }
*ctqv = \&ctqx;  # just for consistency

# Constructor, and copy constructor as clone, with $proto
sub new {
    my $proto = shift;
    my $self = $proto->SUPER::new(@_);
    if ($self->ipc) {
        no strict 'refs'; # $proto may be a symbolic hash
	if ($proto->ipc && $self->{IPC}->{PID} == $proto->{IPC}->{PID}) {
	    ++$pidcount{$self->{IPC}->{PID}};
	    # Correct the effect of the base cloning on globs
	    $self->{IPC}->{DOWN} = $proto->{IPC}->{DOWN};
	    $self->{IPC}->{BACK} = $proto->{IPC}->{BACK};
	}
    }
    bless $self, ref($proto) ? ref($proto) : $proto;
    return $self;
}
*clone = \&new;

# Clean up leftover cleartool processes if user forgot to.
sub DESTROY {
    my $self = shift;
    my $ret = $?;
    $self->ipc(0) if $self->ipc;
    $? |= $ret;
}

1;

__END__