VCS::CMSynergy::Client - base class for CM Synergy methods that don't require a session

  use VCS::CMSynergy::Client;

  $client = VCS::CMSynergy::Client->new(%attr);

  $ary_ref = $client->ps;
  $short_version = $client->version;
  @ary = $client->status;

  $client->trace(1, "trace.out");
  $client->trace_msg("now tracing ccm calls...\n");

  @ary = $client->databases;
  @ary = $client->hostname;

  $ps = VCS::CMSynergy->ps;

  foreach my $ccm_home (qw(/usr/local/ccm51 /usr/local/ccm62 /usr/local/ccm63))
  {
      print "installation in $ccm_home ...\n";
      my $client = VCS::CMSynergy::Client->new(CCM_HOME => $ccm_home);

      foreach my $db ($client->databases)
      {
	  ...
      }
  }

  my $client = VCS::CMSynergy::Client->new( CCM_HOME => "/usr/local/ccm62" );

  print "CCM_HOME=", $client->ccm_home;

  $last_error = $client->error;

  $last_cmsynergy_command = $client->ccm_command;

  $ary_ref = $client->ps;
  $ary_ref = $client->ps(user => "jdoe", process => "gui_interface", ...);

  $ps = [
      {
	'process' => 'router',
	'host' => 'tiv01',
	'rfc_address' => 'tiv01:5415:160.50.76.15',
	'user' => 'ccm_root',
	'host_addr' => '',
	'pid' => '9428'
      },
      {
	'process' => 'gui_interface',
	'database' => '/ccmdb/tbd/slc/db',
	'engine_address' => 'tiv01:60682:160.50.76.15',
	'host' => 'lapis',
	'user' => 'q076273',
	'msg_handler_1' => 'uissys:message_handler',
	'display' => '',
	'callback' => 'vistartup:cb_init',
	'rfc_address' => 'lapis:1934:160.50.136.36',
	'pid' => '224',
	'host_addr' => ''
      },
      {
	'process' => 'engine',
	'database' => '/ccmdb/tbd/nasa_ix/db',
	'host' => 'nasaora',
	'user' => 'qx06322',
	'callback' => 'engine_startup:cb_init',
	'rfc_address' => 'nasaora:1559:160.48.78.33',
	'pid' => '24490',
	'host_addr' => '',
	'ui_address' => 'nasaora:1556:160.48.78.33'
      },
      {
	'process' => 'objreg',
	'db' => [
		  '/ccmdb/tbd/slc/db',
		  '/ccmdb/tbd/eai/db',
		  ...
		],
	'max_conns' => '256',
	'objreg_machine_addr' => '160.50.76.15',
	'host' => 'tiv01',
	'user' => 'ccm_root',
	'callback' => 'objreg:cb_init',
	'policy' => 'one_per_db',
	'noblock' => 'true',
	'rfc_address' => 'tiv01:60352:160.50.76.15',
	'objreg_machine' => 'tiv01',
	'host_addr' => '',
	'pid' => '9896',
	'objreg_machine_hostname' => 'tiv01'
      },
      ...
  ];

  $ary_ref = $client->status;

  $status = [
      {
	'process' => 'gui_interface',
	'database' => '/ccmdb/scm/support/db',
	'rfc_address' => 'tiv01:53020:160.50.76.15',
	'user' => 'rschupp'
      },
      {
	'process' => 'gui_interface',
	'database' => '/ccmdb/scm/support/db',
	'rfc_address' => 'wmuc111931:4661:160.50.136.201',
	'user' => 'rschupp'
      },
      {
	'process' => 'cmd_interface',
	'database' => '/ccmdb/test/tut51/db',
	'rfc_address' => 'tiv01:53341:160.50.76.15',
	'user' => 'rschupp'
      }
  ];

  $short_version = $client->version;
  ($full_version, $schema_version, 
    $informix_version, @patches) = $client->version;

  $client->trace($trace_level);
  $client->trace($trace_level, $trace_filename);

  CMSYNERGY_TRACE=2 perl your_test_script.pl

  CMSYNERGY_TRACE=1=trace.log perl your_test_script.pl

  $client->trace_msg($message_text);
  $client->trace_msg($message_text, $min_level);

  $ccm->set_error($error);
  $ccm->set_error($error, $method);
  $ccm->set_error($error, $method, $rv, @rv);

  $client->run(\@cmd, $in, $out, $err);

  @databases = $client->databases;
  @databases = $client->databases($servername);

  $hostname = $client->hostname.

package VCS::CMSynergy::Client;

# Copyright (c) 2001-2010 argumentum GmbH, 
# See COPYRIGHT section in VCS/CMSynergy.pod for usage and distribution rights.

our $VERSION = do { (my $v = q$Revision: 381 $) =~ s/^.*:\s*//; $v };

use 5.006_000;					# i.e. v5.6.0
use strict;

use Carp;
use Config;
use Cwd;
use File::Spec;
use IPC::Run3;

# Unix only
use IO::Handle;
use IO::Select;
use IO::File;
use IO::Pipe;					# make ActiveState PerlApp happy

use constant is_win32 => $^O eq 'MSWin32' || $^O eq 'cygwin';
use constant _pathsep => is_win32 ? "\\" : "/" ;

our ($Debug, $Debugfh, $Error, $Ccm_command, $Default);

use Exporter();
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
    is_win32 _pathsep $Debug $Error $Ccm_command
    _exitstatus _error _usage);
sub _usage(\@$$$);

{
    $Debug = $ENV{CMSYNERGY_TRACE} || 0;
    $Debugfh = IO::Handle->new_from_fd(\*STDERR, "w");
    if ($Debug)
    {
	if ($Debug =~ /^\d+$/) 			# CMSYNERGY_TRACE="digits"
	{ 
	    # level=digits, tracefile=stderr
	    __PACKAGE__->trace($Debug, undef); 	
	}
	elsif ($Debug =~ /^(\d+)=(.*)/) 	# CMSYNERGY_TRACE="digits=filename"
	{
	    # level=digits, tracefile=filename
	    __PACKAGE__->trace($1, $2); 
	}
	else					# CMSYNERGY_TRACE="filename"
	{
	    # level=2, tracefile=filename
	    __PACKAGE__->trace(2, $Debug); 	
	}
    }
}

our %opts = 
(
    HandleError		=> undef,
    PrintError		=> undef,
    RaiseError		=> undef,
    CCM_HOME		=> undef,
);


sub new
{
    my ($class, %args) = @_;

    my $self = 
    {
	HandleError	=> undef,
	PrintError	=> 1,
	RaiseError	=> 0,
	CCM_HOME	=> $ENV{CCM_HOME},
	env		=> {},
	ccm_command	=> undef,
	error		=> undef,
	out		=> undef,
	err		=> undef,
    };	
    bless $self, $class;

    while (my ($arg, $value) = each %args)
    {
	croak(__PACKAGE__."::new: unrecognized argument: $arg") 
	    unless exists $opts{$arg};

	$self->{$arg} = $value;
    }

    return $self->set_error("CCM_HOME is not set (neither as parameter to new() nor in environment")
	unless defined $self->{CCM_HOME};
    $self->{env}->{CCM_HOME} = delete $self->{CCM_HOME};

    my $ccm_exe = File::Spec->catfile(
	$self->{env}->{CCM_HOME}, "bin", "ccm$Config{_exe}");
    return $self->set_error("CCM_HOME = `$self->{env}->{CCM_HOME}' does not point to a valid CM Synergy installation")
	unless -x $ccm_exe || ($^O eq 'cygwin' && -e $ccm_exe);
	# NOTE: -x $ccm_exe fails on cygwin
    $self->{ccm_exe} = $ccm_exe;

    return $self;
}


sub _memoize_method 
{
    _usage(@_, 3, 3, '$class, $method, $code');

    my ($class, $method, $code) = @_; 
    croak(__PACKAGE__.qq[::_memoize_method: "$code" must be a CODE ref]) 
	unless ref $code eq "CODE";
    my $slot = $method;

    no strict 'refs';
    no warnings 'redefine';
    *{"${class}::${method}"} = sub 
    {
	my $self = shift;
	$self->{$slot} = &$code($self, @_) unless exists $self->{$slot};
	return $self->{$slot};
    };
}


sub start
{
    my ($this, %args) = @_;
    $this = __PACKAGE__->_default unless ref $this;

    return VCS::CMSynergy->_start($this, %args);
}


sub _default	{ $Default ||= shift->new(); }


sub ccm						# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;

    my ($rc, $out, $err) = $this->_ccm(@_);

    return wantarray ? ($rc, $out, $err) : 1 if $rc == 0;
    return $this->set_error($err || $out, undef, 0, $rc, $out, $err);
    # NOTE: most failing ccm commands issue there error messages on stdout!
}


my $ccm_prompt = qr/^ccm> /m;		# NOTE the trailing blank

sub _ccm
{
    my $this = shift;
    my $opts = @_ && ref $_[-1] eq "HASH" ? pop : {};

    $Error = $this->{error} = undef;
    $Ccm_command = $this->{ccm_command} = join(" ", @_);

    my %ropts = %$opts;
    my $rin  = exists $ropts{in}  ? delete $ropts{in}  : \undef;
    my $rout = exists $ropts{out} ? delete $ropts{out} : do { my $s; \$s };
    my $rerr = exists $ropts{err} ? delete $ropts{err} : do { my $s; \$s };
    my $rc;

    my $t0;
    if ($Debug)
    {
	$t0 = [ Time::HiRes::gettimeofday() ];
	if ($Debug >= 8)
	{
	    # NOTE: log the command _before_ executing it to help
	    # diagnose "hung" scripts (e.g. a ccm command waiting for 
	    # user confirmation)
	    $this->trace_msg("<- ccm($this->{ccm_command})\n", 8);
	}
    }

    CCM:
    {
	if ($this->{coprocess})
	{
	    USE_COPROCESS:
	    {
		# don't use copress when using fancy run3() arguments
		last USE_COPROCESS if %$opts;

		# arguments cannot contain newlines in "interactive" ccm sessions
		last USE_COPROCESS if grep { /\n/ } @_;

		my ($dev, $ino) = stat(".") or last USE_COPROCESS;
		if ($this->{co_cwd_dev} != $dev || $this->{co_cwd_ino} != $ino)
		{
		    # working directory has changed since coprocess was spawned:
		    # shut down coprocess and start a new one
		    # NOTE: don't call _ccm here (infinite recursion)
		    $this->_kill_coprocess;
		    unless ($this->_spawn_coprocess)
		    {
			carp(__PACKAGE__ . " _ccm: can't re-establish coprocess (because cwd changed): $this->{error}\n" .
			     "-- ignoring UseCoprocess from now on");
			last USE_COPROCESS;
		    }
		    $Debug && $this->trace_msg(
			"spawned new coprocess because cwd changed (pid=".$this->{coprocess}->pid.")\n", 8);
		}

		# NOTE: "interactive" command arguments that contain blanks must 
		# be quoted with double quotes; AFAICT there is no way 
		# to quote embedded quotes!
		$this->{coprocess}->print(
		    join(" ", map { qq["$_"] } @_), "\n");

		$this->{coprocess}->expect(undef, -re => $ccm_prompt)
		    or return _error("expect error: ".$this->{coprocess}->error);

		# on Windows, treat output as if read in "text" mode
		$$rout = $this->{coprocess}->before;

		$this->{coprocess}->print("set error\n");
		$this->{coprocess}->expect(undef, -re => $ccm_prompt)
		    or return _error("expect error: ".$this->{coprocess}->error);
		my $set = $this->{coprocess}->before;
		($rc) = $set =~ /^(\d+)/
		    or return _error("unrecognized result from `set error': $set");
		($rc, $$rerr) = (_exitstatus($rc), "");
		last CCM;
	    }
	}

	# simple ccm sub process
	$rc = $this->run([ $this->ccm_exe, @_ ], $rin, $rout, $rerr, \%ropts);
    }

    unless (exists $opts->{out})
    {
	$$rout =~ s/\015\012/\012/g if is_win32;	# as if read in :crlf mode
	$$rout =~ s/\n\z//;				# chomp
    }
    unless (exists $opts->{err})
    {
	$$rerr =~ s/\015\012/\012/g if is_win32;	# as if read in :crlf mode
	$$rerr =~ s/\n\z//;				# chomp
    }

    if ($Debug)
    {
	my $elapsed = sprintf("%.2f", Time::HiRes::tv_interval($t0));
	if ($Debug >= 8)
	{
	    $this->trace_msg("-> rc = $rc [$elapsed sec]\n", 8);
	    $this->trace_msg("-> out = \"$$rout\"\n", 8) unless exists $opts->{out};
	    $this->trace_msg("-> err = \"$$rerr\"\n", 8) unless exists $opts->{err};
	}
	else
	{
	    my $success = $rc == 0 ? "ok" : "failed";
	    $this->trace_msg("ccm($this->{ccm_command}) = $success [$elapsed sec]\n");
	}
    }

    $this->{out} = $$rout unless exists $opts->{out};
    $this->{err} = $$rerr unless exists $opts->{err};

    return ($rc, exists $opts->{out} ? undef : $$rout, exists $opts->{err} ? undef : $$rerr);
}

sub run
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;

    # augment %ENV
    my $env = $this->{env};
    local @ENV{keys %$env} = values %$env if defined $env;

    # don't screw up global $? (e.g. when being called 
    # in VCS::CMSynergy::DESTROY at program termination)
    local $?;			
    run3(@_);
    return $?;
}

sub _spawn_coprocess
{
    my $self = shift;

    unless (eval "use Expect 1.15; 1")
    {
	$Error = $self->{error} = $@;
	return;
    }

    # augment %ENV
    my $env = $self->{env};
    local @ENV{keys %$env} = values %$env if defined $env;

    my $exp = Expect->new
	or $Error = $self->{error} = "Expect->new failed", return;
    ($exp->log_stdout(0) && $exp->slave->set_raw && $exp->set_raw)
	or $Error = $self->{error} = $exp->exp_error, return;
    $exp->spawn($self->ccm_exe)
	or $Error = $self->{error} = $exp->exp_error, return;
    
    # look for initial "ccm> " prompt
    $exp->expect(undef, -re => $ccm_prompt)
	or $Error = $self->{error} = $exp->exp_error, return;

    $self->{coprocess} = $exp;

    # remember coprocess' working directory
    # (so that we can detect whether the current working directory
    # of the main process has diverged)
    @$self{qw/co_cwd_dev co_cwd_ino/} = stat(".");

    return 1;
}

sub _kill_coprocess
{
    my $self = shift;
    $self->{coprocess}->print("exit\n");
    # FIXME: kill it just for paranoia (must save pid before line above!)
    $self->{coprocess} = undef;
}

# helper: inverse function of POSIX::WEXITSTATUS()
sub _exitstatus	{ return $_[0] << 8; }

# helper: return a triple ($rc, $out, $err)
sub _error	{ return (_exitstatus(255), "", $_[0]) }

# helper: check usage
# check min ($minargs) and max ($maxargs) number of arguments;
# use $maxargs=undef for unlimited arguments;
# for methods, you should shift $self off @_ before calling _usage();
# croak with message constructed from $usage
sub _usage(\@$$$)
{
    my ($args, $minargs, $maxargs, $usage) = @_;
    return 1 if $minargs <= @$args && (!defined $maxargs || @$args <= $maxargs);
    my $fullname = (caller(1))[3];
    (my $method = $fullname) =~ s/^.*:://;
    croak("$fullname: called with invalid number of arguments" .
          "\n  should be $usage");
}

sub error
{
    my $this = shift;
    return ref $this ? $this->{error} : $Error;
}

sub ccm_command
{
    my $this = shift;
    return ref $this ? $this->{ccm_command} : $Ccm_command;
}

sub ccm_home					# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;
    return $this->{env}->{CCM_HOME};
}

sub ccm_exe					# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;
    return $this->{ccm_exe};
}

sub out 					# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;
    return wantarray ? split(/\n/, $this->{out}) : $this->{out};
}

sub err 					# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;
    return $this->{err};
}

# NOTE: we can't memoize "version", as the memoizing wrapper
# assumes an object (not a class) as invocant
sub version					# class/instance method
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;

    my $version = $this->_version;
    return @$version{qw(cmsynergy schema informix patches)} if wantarray;
    return $version->{short};
}

__PACKAGE__->_memoize_method(_version => sub
{
    my $self = shift;

    # "version" is not a recognized "interactive" command
    local $self->{coprocess} = undef;

    my ($rc, $out, $err) = $self->_ccm(qw/version -all/);
    return $self->set_error($err || $out) unless $rc == 0;

    my %version;
    my $cmsynergy_rx = qr{(?:CM Synergy|SYNERGY/CM|Telelogic Synergy|IBM Rational Synergy)};
    ($version{cmsynergy}) = $out =~ /^$cmsynergy_rx Version\s+(\S*)$/imo
	or return $self->set_error("can't recognize version from `$out'");
    ($version{short}) = $version{cmsynergy} =~ /^(\d+\.\d+)/;
    
    ($version{schema}) = $out =~ /^$cmsynergy_rx Schema Version\s+(.*)$/imo;
    ($version{informix}) = $out =~ /^Informix.* Version\s+(.*)$/imo;
    $version{patches} = [ split(/\n/, $1) ]
	if $out =~ /^$cmsynergy_rx Patch Version\s+(.*?)(?:\Z|^$cmsynergy_rx|^Informix)/imso; 
    return \%version;
});


sub ps	
{
    my ($this, @filter) = @_;
    $this = __PACKAGE__->_default unless ref $this;

    # "ps" is not a recognized "interactive" command
    local $this->{coprocess} = undef;

    my ($rc, $out, $err) = $this->_ccm(qw/ps/, @filter);
    return $this->set_error($err || $out) unless $rc == 0;

    # split at "rfc address..." header lines;
    # discard first item (the line "All Rfc processes..." or
    # "Processes with...")
    # NOTE: We do it this way (and not by splitting into lines
    # first, then recognizing "rfc address..." lines as 
    # record headers) to work around a Synergy glitch:
    # if the single line in $CCM_HOME/etc/.router.adr ends with
    # a newline, then the record for the router process
    # will look like:
    #   rfc address (macarthur:5418:127.0.1.1:192.168.57.10
    #   )
    #         process (router)
    #         user (ccm_root)
    # i.e. the address contains an embedded newline. This
    # breaks line-based parsing.
    my @rfcs = split(/^rfc address \((.*?)\)/sm, $out);
    shift @rfcs;	

    my @ps;
    while (@rfcs)
    {
	my ($rfc_address, $rest) = splice @rfcs, 0, 2;
	chomp ($rfc_address, $rest);

	my %fields = $rest =~ /^\t(\S+) \((.*?)\)/gm;

	# the ps entry for the objreg process contains lines of the form
	#   db:/var/lib/telelogic/ccm65/tutorial_pre64sp1/db ()
	# transform the (database) paths into a list 
	# as the value of key "db"
	my @dbs;
	foreach my $key (keys %fields)
	{
	    if ($key =~ /^db:(.*)$/)
	    {
		push @dbs, $1;
		delete $fields{$key};
	    }
	}

	$fields{rfc_address} = $rfc_address;
	$fields{db} = \@dbs if @dbs;

	push @ps, \%fields;
    }

    return \@ps;
}


sub status	
{
    my $this = shift;
    $this = __PACKAGE__->_default unless ref $this;

    my ($rc, $out, $err) = $this->_ccm(qw/status/);
    return $this->set_error($err || $out) unless $rc == 0;

    my (@sessions, $session, $user);
    foreach (split(/\n/, $out))
    {
	if (/sessions for user (\S+):/i)
	{
	    $user = $1;
	    next;
	}
	if (my ($interface, $rfc_address) = /^(.*?) interface \@ (\S+)/i)
	{
	    # start of a session description;
	    # convert interface to process name used by `ccm ps'
	    $session = 
	    {
		process		=> $interface =~ /graphical/i ? 
				     "gui_interface" : "cmd_interface",
		rfc_address	=> $rfc_address,
		user		=> $user,
	    };
	    push @sessions, $session;
	    next;
	}
	if (/^database: (.*)/i && $session)
	{
	    # sanitize database path (all other CM Synergy information commands
	    # show it with trailing "/db", so we standardize on that)
	    # NOTE: careful here, because the database might reside on Windows
	    ($session->{database} = $1) 		
		=~ s{^(.)(.*?)(\1db)?$}{$1$2$1db};
	    next;
	}
    }
    return \@sessions;
}


# FIXME does not work on Windows 
# (in fact, it only works on the host where Synergy's Informix engine is running)
sub databases	
{
    my ($this, $servername) = @_;
    $this = __PACKAGE__->_default unless ref $this;

    my @server_status = 
	(File::Spec->catfile($this->ccm_home, qw/bin ccmsrv/), qw/status/);
    push @server_status, -s => $servername if defined $servername;

    my ($out, $err);
    my $rc = $this->run(\@server_status, \undef, \$out, \$err);
    chomp ($out, $err);
    return $this->set_error($err || $out) unless $rc == 0;

    # strip leading/trailing stuff
    my ($list) = $out =~ /^===.*?$(.*?)^There is a total/ms;
    return $this->set_error(qq[unrecognized output from "@server_status": $out])
	unless defined $list;
    return grep { !/dbpath not available/ }
           map  { (split(' ', $_, 3))[2]  } 
	   split(/\n/, $list);
}

# FIXME does not work on windows 
sub hostname
{
    my ($this, @filter) = @_;
    $this = __PACKAGE__->_default unless ref $this;

    our %Hostname;				# cache by CCM_HOME
    my $ccm_home = $this->ccm_home;
    unless (exists $Hostname{$ccm_home})
    {
	my ($out, $err);
	my $rc = $this->run([ File::Spec->catfile($ccm_home, qw/bin util ccm_hostname/) ], \undef, \$out, \$err);
	chomp($out, $err);
        # ignore bogus exit code (seems to be length of output in bytes, arghh)
	$Hostname{$ccm_home} = $out;
    }

    return $Hostname{$ccm_home};
}


sub trace
{
    my ($this, $trace_level, $trace_filename) = @_;
    return $Debug unless defined $trace_level;

    require Time::HiRes;
    ($Debug, $trace_level) = ($trace_level, $Debug);

    if (@_ == 3)				# $trace_filename present
    {
	# switch trace files
	my $newfh = defined $trace_filename ?
	    IO::File->new($trace_filename, "a") : 
	    IO::Handle->new_from_fd(\*STDERR, "w");
	unless ($newfh)
	{
	    carp(__PACKAGE__ . " trace: can't open trace file `$trace_filename'");
	    return $trace_level;
	}
	$newfh->autoflush(1);
	close($Debugfh);
	$Debugfh = $newfh;
	$Debug && $this->trace_msg(__PACKAGE__ . " version $VERSION [$^O]: trace started\n");
    }
    $Debug && $this->trace_msg("trace level set to $Debug\n");
    return $trace_level;
}

sub trace_msg
{
    my ($this, $message, $min_level) = @_;
    $min_level ||= 1;
    print $Debugfh "[$this] $message" if $Debug >= $min_level;
}

sub set_error 
{
    my ($this, $error, $method, $rv, @rv) = @_;

    $Error = $this->{error} = $error;

    # try the HandleError routine if one was provided;
    # consider the error handled if it returns true
    my $handler = $this->{HandleError};
    return wantarray ? @rv : $rv if $handler and &$handler($error, $this, $rv, @rv);

    # unless $method was explicitly specified, use our caller 
    # except skip private methods of VCS::CMsynergy... packages
    unless (defined $method)
    {
	$method = (caller(0))[3];
	for (my $n = 1;; $n++)
	{
	    my $next = (caller($n))[3];
	    last unless defined $next;
	    $method = $next;
	    last unless $method =~ /^VCS::CMSynergy.*::_\w*$/;
	}
    }

    my $msg = "$method: $error";
    croak($msg) if $this->{RaiseError};	
    carp($msg)  if $this->{PrintError};
    return wantarray ? @rv : $rv;
}

1;

__END__