/usr/local/CPAN/VCS-CMSynergy/VCS/CMSynergy.pm
package VCS::CMSynergy;
# Copyright (c) 2001-2010 argumentum GmbH,
# See COPYRIGHT section in VCS/CMSynergy.pod for usage and distribution rights.
# $Revision: 383 $
our $VERSION = '1.35';
use 5.006_000; # i.e. v5.6.0
use strict;
use VCS::CMSynergy::Client qw(
is_win32 $Debug $Error $Ccm_command
_exitstatus _error _usage);
our @ISA = qw(VCS::CMSynergy::Client);
use Carp;
use Config;
use File::Spec;
use File::Temp qw(tempfile); # in Perl core v5.6.1 and later
use constant ROW_ARRAY => 0;
use constant ROW_HASH => 1;
use constant ROW_OBJECT => 2;
BEGIN
{
if ($^O eq 'cygwin')
{
eval "use Filesys::CygwinPaths qw(:all); 1" or die $@;
}
}
sub import
{
my $class = shift;
my %use =
(
tied_objects => 0,
cached_attributes => 0,
);
foreach (@_)
{
my $opt;
die qq[Invalid option "$_" in "use ].__PACKAGE__.qq["]
unless ($opt) = /^[!:](.*)$/i and exists $use{$opt};
$use{$opt} = /^:/ ? 1 : 0;
}
while (my ($opt, $value) = each %use)
{
eval "use constant use_$opt => $value";
}
# require V::C::Object _after_ use_* have been defined,
# so that optimization based on constant expressions can
# e.g. eliminate branches guarded with "if (V::C::use_cached_attributes)"
require VCS::CMSynergy::Object;
require VCS::CMSynergy::ObjectTieHash if use_tied_objects();
}
sub new
{
my ($class, %args) = @_;
my %client_args;
foreach (keys %args)
{
$client_args{$_} = delete $args{$_}
if exists $VCS::CMSynergy::Client::opts{$_};
}
return $class->_start(VCS::CMSynergy::Client->new(%client_args), %args);
}
# %start_opts: its keys are all valid options that can be
# passed to VCS::CMSynergy::_start; moreover,
# if $start_opts{foo} is defined then arg "foo" is automagically
# passed to "ccm start" as "... $start_opts{foo} $args{foo} ..."
my %start_opts =
(
KeepSession => undef,
UseCoprocess => undef,
CCM_ADDR => undef,
ini_file => undef,
remote_client => undef,
database => "-d",
home => "-home",
host => "-h",
server => "-s",
password => "-pw",
role => "-r",
ui_database_dir => "-u",
user => "-n",
);
sub _start
{
my ($class, $client, %args) = @_;
croak(__PACKAGE__."::_start: $client is not a VCS::CMSynergy::Client")
unless UNIVERSAL::isa($client, 'VCS::CMSynergy::Client');
# make a deep clone of $client
my $self = { %$client };
$self->{env} = { %{ $client->{env} } } if $client->{env};
bless $self, $class;
# Cygwin: some start options denote path names that are
# passed down to Synergy; convert them to native Windows form
if ($^O eq 'cygwin')
{
foreach (qw/home ini_file ui_database_dir/)
{
$args{$_} = fullwin32path($args{$_}) if defined $args{$_};
}
}
my @start = qw/start -m -q -nogui/;
# FIXME 7.1 web mode:
# - in effect when "-s" i.e. $args{server} is specified
# - "-f" not allowed
while (my ($arg, $value) = each %args)
{
croak(__PACKAGE__.qq[::_start: unrecognized argument "$arg"])
unless exists $start_opts{$arg};
$self->{$arg} = $value unless $arg eq "password";
push @start, $start_opts{$arg} => $value if defined $start_opts{$arg};
}
$self->{env}->{CCM_ADDR} = delete $self->{CCM_ADDR} if defined $self->{CCM_ADDR};
push @start, '-rc' if $self->{remote_client};
if (defined $self->ccm_addr)
{
$self->{KeepSession} = 1 unless defined $self->{KeepSession};
if ($Debug)
{
my $ccm_addr = $self->ccm_addr;
$self->trace_msg($self->{KeepSession} ?
qq[will keep session "$ccm_addr"\n] :
qq[will not keep session "$ccm_addr"\n]);
}
if (is_win32)
{
# figure out user of session specified by CCM_ADDR
$self->{user} =
$self->ps(rfc_address => $self->ccm_addr)->[0]->{user};
# FIXME not necessary in web mode
# ccm ps: process (usr_cmd_interface)
# create a minimal ini file (see below for an explanation)
(my $inifh, $self->{ini_file}) = tempfile(SUFFIX => ".ini", UNLINK => 0);
$self->{ini_file} = fullwin32path($self->{ini_file}) if $^O eq 'cygwin';
# because this name is passed down to ccm.exe
print $inifh "[UNIX information]\nUser = $self->{user}\n";
close($inifh);
push @{ $self->{files_to_unlink} }, $self->{ini_file};
}
}
else
{
# NOTE: If neither database nor CCM_ADDR was specified "ccm start ..."
# will fail later on, but with rather cryptic messages from CM Synergy;
# hence better fail early
return $self->set_error("don't know how to connect to CM Synergy: neither database nor CCM_ADDR specified")
unless $args{database};
unless ($self->{server}) # NOTE: "-f" is illegal in web mode
{
unless (defined $self->{ini_file})
{
if (is_win32)
{
# NOTES:
# (1) "ccm start -f nul ..." doesn't work on Windows
# (leads to error from ccm_seng),
# so use an empty ini_file instead
# (2) we can't use UNLINK=>1 with tempfile, because
# the actual unlink may occur before the session is
# stopped and Windows refuses removing the "busy" file
(undef, $self->{ini_file}) = tempfile(SUFFIX => ".ini", UNLINK => 0);
$self->{ini_file} = fullwin32path($self->{ini_file}) if $^O eq 'cygwin';
push @{ $self->{files_to_unlink} }, $self->{ini_file};
}
else
{
$self->{ini_file} = File::Spec->devnull;
}
}
push @start, "-f", $self->{ini_file};
}
my ($rc, $out, $err) = $self->_ccm(@start);
return $self->set_error($err || $out) unless $rc == 0;
$self->{env}->{CCM_ADDR} = $out;
$Debug && $self->trace_msg(qq[started session "$out"\n]);
}
# NOTE: Use of $CCM_INI_FILE fixes the annoying `Warning:
# Security violation. User JLUSER is not authorized to the
# Continuus interface at ...' when running on Windows.
#
# Background: The problem is the obsolete ccm.ini file in
# Windows' %SystemRoot%. If ccm_gui or "ccm start ..." is
# invoked _without_ specifying an ini file it writes the
# Unix user (as given in the login popup or -n option, resp.)
# into this file. If $CCM_INI_FILE is not set, all other "ccm ..."
# invocations will read this file and check its "user"
# entry against the session identified by $CCM_ADDR. If
# they don't match, the above warning is issued and the
# command aborted. If we already have have an ini_file we
# just set $CCM_INI_FILE to its name. Otherwise we fake
# a minimal ini file with the correct setting of "user"
# and set $CCM_INI_FILE to its name.
#
# NOTE: CM Synergy versions >= 6.0 on Windows do not use
# %SystemRoot%\ccm.ini any more. However, the problem persists:
# if there's a [UNIX information] section in $CCM_HOME\etc\ccm.ini
# or the user's personal ccm.ini its "User" setting will be used
# and may trigger the "security violation".
$self->{env}->{CCM_INI_FILE} = $self->{ini_file} if is_win32;
# remember the process that created $self (so we can check in DESTROY)
$self->{pid} = $$;
# FIXME how can I determine that current session is
# in web mode if it's an "inherited" session?
$self->{web_mode} = 1 if $self->{server};
# web mode renames the %filename placeholder (cf. "ccm set text_editor")
$self->{"%filename"} = $self->{web_mode} ? "%file" : "%filename";
if ($self->{UseCoprocess})
{
if ($self->_spawn_coprocess)
{
$Debug && $self->trace_msg("spawned coprocess (pid=".$self->{coprocess}->pid.")\n", 8);
}
else
{
carp(__PACKAGE__." new: can't establish coprocess: $self->{error}\n" .
"-- ignoring UseCoprocess");
}
}
# cache some info from database; this also doubles as a test for a valid session
{
my ($rc, $out, $err) = $self->_ccm(qw/delimiter/);
return $self->set_error($err || $out) unless $rc == 0;
$self->{delimiter} = $out;
$self->{objectname_rx} =
qr/^(.*?)(?:\Q$self->{delimiter}\E|:)(.*?):(.*?):(.*?)$/;
# -> (name, version, cvtype, instance)
$self->{finduse_rx} =
qr/^\t(.*?)\Q$self->{delimiter}\E.*?\@(.*?)$/;
# -> (path, project)
}
# NOTE: If option `database' was present it may not be in the
# canonical form; purge it from $self so that $self->database
# will recompute it on demand.
delete $self->{database};
$self->{objects} = {} if use_cached_attributes();
if ($Debug >= 9)
{
require Data::Dumper;
local $Data::Dumper::Useqq = 1;
$self->trace_msg(Data::Dumper->Dump([$self], ["$self"]));
}
return $self;
}
sub DESTROY
{
my $self = shift;
# no-op if the session has not yet been established
return unless $self->ccm_addr;
# no-op if this is not the process that created $self
return unless $self->{pid} == $$;
# NOTE: DESTROY might be called implicitly while unwinding
# stack frames during exception processing, e.g.
#
# eval {
# my $ccm = VCS::CMSynergy->new(...);
# ...
# die "D.O.A." # <-- exception thrown
# ...
# };
# print "oops: $@\n" if $@; # <-- handle it
#
# The exception causes a premature exit from the eval block.
# But this block is also the scope of $ccm, hence $ccm->DESTROY
# is called. Any eval block encountered during processing of DESTROY()
# will reset $@ - even if no excpetion is thrown. Hence $@
# might be empty at "print...".
# We localize $@ to avoid this unexpected behaviour.
# FIXME: might be more correct to push localization into the
# offending methods.
local $@;
local $?; # don't screw up global $?
$self->_kill_coprocess if $self->{coprocess};
# don't stop session if KeepSession is set
unless ($self->{KeepSession})
{
$self->_ccm(qw/stop/);
$Debug && $self->trace_msg("stopped session ".$self->ccm_addr."\n");
}
# on Windows, certain files (e.g. the fake ccm.ini) might still be busy
my @files_to_unlink;
foreach (@{ $self->{files_to_unlink} })
{
unlink($_) or push @files_to_unlink, $_;
}
if (is_win32 && @files_to_unlink)
{
# wait a little, then try again
sleep(2);
unlink(@files_to_unlink);
}
%$self = (); # paranoia setting
}
sub ccm_addr { return shift->{env}->{CCM_ADDR}; }
sub delimiter { return shift->{delimiter}; }
sub _my_ps
{
my ($self, $field) = @_;
my $ccm_addr = $self->ccm_addr;
my $ps = $self->ps(rfc_address => $ccm_addr);
return $self->set_error("can't find current session `$ccm_addr' in `ccm ps'")
unless $ps && @$ps > 0;
return $ps->[0]->{$field};
}
# determine database path (in canonical format) etc from `ccm ps'
__PACKAGE__->_memoize_method(database => sub { shift->_my_ps('database'); });
__PACKAGE__->_memoize_method(user => sub { shift->_my_ps('user'); });
sub query
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/query -u/, @_);
# NOTE: if there are no hits, `ccm query' exits with status 1,
# but produces no output on either stdout and stderr
return [ split(/\n/, $out) ] if $rc == 0;
return [ ] if $rc == _exitstatus(1) and $out eq "" and $err eq "";
return $self->set_error($err || $out);
}
sub query_arrayref
{
my $self = shift;
_usage(@_, 1, undef, '$query, @keywords');
my $query = shift;
return $self->_query($query, \@_, ROW_ARRAY);
}
sub query_hashref
{
my $self = shift;
_usage(@_, 1, undef, '$query, @keywords');
my $query = shift;
return $self->_query($query, \@_, ROW_HASH);
}
sub query_object
{
my $self = shift;
_usage(@_, 1, undef, '$query, @attributes');
my $query = shift;
return $self->_query($query, \@_, ROW_OBJECT);
}
*query_object_with_attributes = \&query_object; # compatibility alias
sub query_count
{
my $self = shift;
_usage(@_, 1, 1, '$query');
my $query = shift;
my ($rc, $out, $err) = $self->_ccm(
qw/query -u -ns -nf -format X/, $self->_expand_query($query));
# NOTE: if there are no hits, `ccm query' exits with status 1,
# but produces no output on either stdout and stderr
return 0 if $rc == _exitstatus(1) and $out eq "" and $err eq "";
return $out =~ tr/X/X/ if $rc == 0; # count 'em X's
return $self->set_error($err || $out);
}
# NOTE: We use \cA and \cD as record/field separators.
# SYNERGY/Change uses \x1C-\x1E in attribute
# "transition_log" of "problem" objects, so these are out.
# Also people have been known to enter strange characters
# like \cG even when using a GUI exclusively.
# Change these at your own risk, YMMV.
our $RS = "\cA"; # record separator for query etc
our $FS = "\cD"; # field separator for query etc
# helper method: query with correct handling of multi-line attributes
sub _query
{
my ($self, $query, $keywords, $row_type) = @_;
$query = $self->_expand_query($query);
my $want = _want($row_type == ROW_OBJECT, $keywords);
my $want_finduse = delete $want->{finduse};
croak(__PACKAGE__.qq[::_query: keyword "finduse" not allowed when ROW_OBJECT wanted])
if $want_finduse && $row_type == ROW_OBJECT;
my $format = $RS . join($FS, values %$want) . $FS;
my ($rc, $out, $err) = $want_finduse ?
$self->_ccm_with_option(
Object_format => $format,
qw/finduse -query/ => $query) :
$self->_ccm(
qw/query -u -ns -nf -format/ => $format, $query);
# NOTE: if there are no hits, `ccm query' exits with status 1,
# but produces no output on either stdout and stderr
return [ ] if $rc == _exitstatus(1) && $out eq "" && $err eq "";
# NOTE: if the query string contained a syntax error, Synergy
# prints "Syntax error in query request", but won't tell you the
# query string, making it hard to diagnose the problem.
# So append the query string to the error message.
return $self->set_error(($err || $out).qq[\n Query was "$query"])
unless $rc == 0;
my @result;
foreach (split(/\Q$RS\E/, $out)) # split into records
{
next unless length($_); # skip empty leading record
my @cols = split(/\Q$FS\E/, $_, -1); # don't strip empty trailing fields
my %finduse;
if ($want_finduse)
{
# finduse information is the last "column"
my $fu_lines = pop @cols;
# finduse lines are of the forms
#
# \t relative_path/name-version@pname-pversion
# \t relative_path/name-version@pname-pversion:project:pinstance
#
# which we parse into a hash
# "project_objectname" => "relative_path/name"
# NOTE: Starting with CCM 6.3, project objects may have instances
# other than '1' (either for DCM reasons, or because someone
# created a second project with the same name while the
# model attribute "multiple_local_proj_instances" was TRUE).
# CCM 6.3 apparently still returns "proj_vers" if instance='1' and
# the full objectname otherwise. We return the full objectname
# in any case.
unless ($fu_lines =~ /Object is not used in scope/)
{
foreach (split(/\n/, $fu_lines))
{
next if /^\s*$/;
my ($path, $project) = /$self->{finduse_rx}/
or return $self->set_error(
qq[unrecognizable line returned from "finduse -query": "$_"]);
$finduse{$self->_projspec2objectname($project)} = $path;
}
}
}
my $row = $self->_parse_query_result($want, \@cols, $row_type == ROW_OBJECT);
$row->{finduse} = \%finduse if $want_finduse;
push @result, $row;
}
if ($row_type == ROW_ARRAY)
{
$_ = [ @$_{@$keywords} ] foreach @result;
}
return \@result;
}
# Sigh. "ccm query -f %objectname" returns old-style fullnames
# (i.e. "instance/cvtype/name/version") for certain legacy types of
# objects, e.g. "cvtype" and "attype". But CM Synergy
# doesn't accept these where a "file_spec" is expected
# (at least on Unix, because they contain slashes).
# Hence rewrite these fullnames to objectnames.
sub _fullname2objectname
{
my ($self, $fullname) = @_;
$fullname =~ s{^(.*?)/(.*?)/(.*?)/(.*?)$}
{$3$self->{delimiter}$4:$2:$1};
return $fullname;
}
# NOTE: The Synergy pseudo attributes (e.g. %task) are implemented in
# baselib/src/base/pseudo_attrs.ac (except for the hard-wired %objectname
# and %displayname) and the table in attribute "pseudo_attrs"
# of base-1:model:base.
# rewrite rules for complex pseudo attributes
# - key is the name of the pseudo attribute
# - value is a hash consisting of:
# format: the string to use in a ccm format option to get the raw value
# rewrite: a sub that will be called with two arguments: a VCS::Synergy
# session and the raw value; it must return the converted value
# NOTE: the raw value will always be defined, because undef ("<void>")
# raw values are automatically passed thru
# row_object_ok: whether this pseudo attribute allowed when the final
# answer is in terms of VCS::CMSynergy::Objects (e.g. query_object())
my %_rewrite_rule =
(
objectname =>
{
format => "%objectname",
rewrite => sub { my ($self, $value) = @_;
$self->_fullname2objectname($value); },
row_object_ok => 1,
},
object =>
{
format => "%objectname",
rewrite => sub { my ($self, $value) = @_;
$self->object($self->_fullname2objectname($value)); },
row_object_ok => 1,
},
task_objects =>
{
format => "%task",
rewrite => sub { my ($self, $value) = @_;
[ map { $self->task_object($_) }
split(/,/, $value) ]; },
row_object_ok => 0,
},
cr_objects =>
{
format => "%change_request",
rewrite => sub { my ($self, $value) = @_;
[ map { $self->cr_object($_) }
split(/,/, $value) ]; },
row_object_ok => 0,
},
baseline_project =>
{
format => "%baseline",
rewrite => sub { my ($self, $value) = @_;
$self->project_object($value); },
row_object_ok => 0,
},
baseline_object =>
{
format => "%in_baseline",
rewrite => sub { my ($self, $value) = @_;
$self->baseline_object($value); },
row_object_ok => 0,
},
);
# helper (not a method): build "want" array from keyword list (common case)
# NOTE: if $want_row_object is true, the keyword "object" will be
# automatically added to the returned hash
sub _want
{
my ($want_row_object, $keywords) = @_;
my %want = map { $_ => "%$_" } @$keywords;
$want{object} = "%objectname" if $want_row_object;
# handle special keywords
foreach (keys %want)
{
if (my $rule = $_rewrite_rule{$_})
{
croak(__PACKAGE__.qq[::_want: keyword "$_" not allowed when ROW_OBJECT wanted])
if $want_row_object && !$rule->{row_object_ok};
$want{$_} = $rule->{format};
}
}
return \%want;
}
sub _parse_query_result
{
my ($self, $want, $cols, $want_row_object) = @_;
my %row;
# strip trailing newline (for consistency with get_attribute()),
# translate "<void>" to undef and fill into correct slots
# NOTE: per construction, @$cols are in the same order as keys %$want
@row{keys %$want} = map { s/\n\z//; /^<void>$/ ? undef : $_ } @$cols;
# handle special keywords
foreach (keys %$want)
{
next unless defined $row{$_};
if (my $rule = $_rewrite_rule{$_})
{
$row{$_} = $rule->{rewrite}->($self, $row{$_});
}
}
if ($want_row_object)
{
my $obj = delete $row{object};
$obj->_update_acache(\%row);
return $obj;
}
return \%row;
}
# helper
sub _expand_query
{
my ($self, $query) = @_;
if (ref $query eq 'HASH')
{
$query = $self->_query_shortcut($query);
}
else
{
# Sanitize query string by replacing whitespace (esp. newlines)
# by a single blank except inside single or double quotes.
# This helps to improve the legibility of longish queries with
# whitespace and line breaks (which CM Synergy's CLI dosen't grok).
$query =~ s/('.*?'|".*?"|[^'"\s]+)|(\s+)/defined $2 ? " " : $1/sge;
}
return $query;
}
my %ac_cvtype = map { $_ => "AC/cvtype/$_/1" }
qw/ admin asm attype bstype cvtype mcomp model pdtype /;
# helper: expand shortcut queries
sub _query_shortcut
{
my ($self, $hashref) = @_;
$Debug >= 5 && $self->trace_msg(
"shortcut query { ".join(", ", map { "$_ => $hashref->{$_}" } keys %$hashref)." }\n", 5);
my @clauses;
while (my ($key, $value) = each %$hashref)
{
my $ref = ref $value;
if ($ref eq '')
{
for ($key)
{
/^task$/ && do # same as "ccm query -task ..."
{
push @clauses, "is_associated_cv_of(task('$value'))";
next;
};
/^match$/ && do
{
push @clauses, "name match '$value'";
next;
};
/^(cv)?type$/ && do
{
# rumor (D. Honey) has it that
# "has_cvtype('base/cvtype/foo/1')" is somehow faster
# than "type='foo'; note that the two are not synonyms,
# since the latter also applies to the AC cvtypes
# like "admin" or "model"
my $cvtype = $ac_cvtype{$value} || "base/cvtype/$value/1";
push @clauses, "has_cvtype('$cvtype')";
next;
};
push @clauses, "$key="._quote_value($value);
}
}
elsif ($ref eq 'ARRAY')
{
my $args = join(",", map { _quote_value($_) } @$value);
push @clauses, "$key($args)";
}
elsif ($ref eq 'HASH')
{
my $nested = $self->_query_shortcut($value);
push @clauses, "$key($nested)";
}
else
{
(my $method = (caller(1))[3]) =~ s/^.*:://;
croak(qq[$method: dunno how to handle "$key => $ref" in shortcut query]);
}
}
my $result = join(" and ", @clauses);
$Debug >= 5 && $self->trace_msg("shortcut query => $result\n", 5);
return $result;
}
# helper (not a method): smart quoting of string or boolean values
# NOTE: CM Synergy seems to use the following quoting rules
# for the right hand side of an "attribute value clause" in a query:
# - string and text values must be quoted
# - boolean values ("TRUE" or "FALSE") must not be quoted
# - integer values must not be quoted, but must always have a leading sign
# - time values must be written as "time('Fri Dec 12 1997')"
sub _quote_value
{
local ($_) = @_;
return /^(TRUE|FALSE)$/ ? $_ : # don't quote boolean
/'/ ? qq["$_"] : # use double quotes if contains single quote
qq['$_']; # use single quotes otherwise
}
sub history
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/history/, @_);
return $self->set_error($err || $out) unless $rc == 0;
return [ split(/^\*+\n?/m, $out) ];
}
sub history_arrayref
{
my $self = shift;
_usage(@_, 1, undef, '$file_spec, @keywords');
my $file_spec = shift;
return $self->_history($file_spec, \@_, ROW_ARRAY);
}
sub history_hashref
{
my $self = shift;
_usage(@_, 1, undef, '$file_spec, @keywords');
my $file_spec = shift;
return $self->_history($file_spec, \@_, ROW_HASH);
}
# helper: history with correct handling of multi-line attributes
sub _history
{
my ($self, $file_spec, $keywords, $row_type) = @_;
my $want = _want($row_type == ROW_OBJECT, $keywords);
my $want_predecessors = delete $want->{predecessors};
my $want_successors = delete $want->{successors};
croak(__PACKAGE__.qq[::_history: keyword "predecessors" or "successors" not allowed when ROW_OBJECT wanted])
if ($want_predecessors || $want_successors) && $row_type == ROW_OBJECT;
my $format = $RS . join($FS, values %$want) . $FS;
# NOTE: documentation says option "-format" is allowed,
# but implementation accepts only "-f"
my ($rc, $out, $err) = $self->_ccm(qw/history -f/, $format, $file_spec);
return $self->set_error($err || $out) unless $rc == 0;
my @result;
foreach (split(/\Q$RS\E/, $out)) # split into records
{
next unless length($_); # skip empty leading record
my @cols = split(/\Q$FS\E/, $_, -1); # don't strip empty trailing fields
# history information is the last "column"
my $history = pop @cols;
my $row = $self->_parse_query_result($want, \@cols, 0);
if ($want_predecessors || $want_successors)
{
# parse history information
my ($predecessors, $successors) = $history =~
/^Predecessors:\n\t?(.*)
^Successors:\n\t?(.*)
^\*
/msx;
if ($want_predecessors)
{
$row->{predecessors} =
[ map { $self->object($_) } split(/\n\t?/, $predecessors) ];
}
if ($want_successors)
{
$row->{successors} =
[ map { $self->object($_) } split(/\n\t?/, $successors) ];
}
}
push @result, $row;
}
if ($row_type == ROW_ARRAY)
{
$_ = [ @$_{@$keywords} ] foreach @result;
}
return \@result;
}
sub finduse
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/finduse/, @_);
# NOTE: `ccm finduse ...' without `-query' complains if some of
# the given objects do not exist (and exits with status 1 unless at least
# one exists). But for `ccm finduse -query ...', if there are no hits,
# the command exits with status 1 and produces no output on either
# stdout and stderr. (This is the same behaviour as for `ccm query ...'.)
# We will not produce an error in any case. However, the returned array
# will contain undef in postions corresponding to non-existing objects.
return [ ] if $rc == _exitstatus(1) and $out eq "" and $err eq "";
return $self->set_error($err || $out) unless $rc == 0;
my (@result, $uses);
foreach (split(/\n/, $out))
{
# push undef for any non-existing objects
if (/Object version could not be identified/)
{
push @result, undef;
next;
}
# ignore the dummy "use" line printed if object is not used anywhere
if (/Object is not used in scope/)
{
next;
}
# a usage line is matched by finduse_rx
if (/$self->{finduse_rx}/)
{
my ($path, $project) = ($1, $2);
$uses->{$self->_projspec2objectname($project)} = $path;
next;
}
# otherwise the line describes an object satisfying the query
# in the format given by option `Object_format' (default:
# "%displayname %status %owner %type %project %instance %task");
# push it with an empty hash of uses (will be filled in by the
# following lines)
push(@result, [ $_, $uses = {} ]);
}
return \@result;
}
sub findpath
{
my ($self, $file_spec, $proj_vers) = @_;
my $finduse = $self->finduse($file_spec);
return unless defined $finduse;
return $self->set_error("`$file_spec' matches more than one object")
unless @$finduse == 1;
return $finduse->[0]->[1]->{$proj_vers};
}
sub relations_hashref
{
my ($self, %args) = @_;
my %defaulted;
foreach my $arg (qw/from_attributes to_attributes/)
{
croak(__PACKAGE__.qq[::relations_hashref: optional argument "$arg" must be an array ref])
if exists $args{$arg} && !UNIVERSAL::isa($args{$arg}, 'ARRAY');
# default keyword "objectname"
unless ($args{$arg})
{
$args{$arg} = [ qw/objectname/ ];
$defaulted{$arg}++;
}
}
my $result = $self->_relations(\%args, 0);
return unless $result;
# if we defaulted "objectname" above, replace the corresponding
# hash containing the sole key "objectname" with its value
foreach my $arg (qw/from to/)
{
if ($defaulted{"${arg}_attributes"})
{
$_->{$arg} = $_->{$arg}->{objectname} foreach @$result;
}
}
return $result;
}
sub relations_object
{
my ($self, %args) = @_;
foreach my $arg (qw/from_attributes to_attributes/)
{
croak(__PACKAGE__.qq[::relations_object: optional argument "$arg" must be an array ref])
if $args{$arg} && !UNIVERSAL::isa($args{$arg}, 'ARRAY');
$args{$arg} ||= []; # _relations below likes 'em defined
}
return $self->_relations(\%args, 1);
}
# helper method: synthesize command and parse result of "ccm relate -show ..."
sub _relations
{
my ($self, $args, $want_row_object) = @_;
# NOTE: $args->{from_attributes}/$args->{to_attributes} must not be undef
my $want_from = _want($want_row_object, $args->{from_attributes});
my $ncol_from = keys %$want_from;
my $want_to = _want($want_row_object, $args->{to_attributes});
my $ncol_to = keys %$want_to;
# NOTE: If the "from" part (the part before "::") of the format
# or the "to" part are empty, Synergy may default it from
# the other part. Hence both "from" and "to" part below are never
# empty, even if $want_from or $want_to are empty.
my $format =
$RS . # record delimiter
join($FS, # column separator
values %$want_from, # "from" part
"::", # will be replaced by name of relation
values %$want_to) . # "to" part
$FS; # will be followed by create_time
my ($rc, $out, $err) = $self->_ccm(
qw/relate -show -format/ => $format,
map { defined $args->{$_} ? ( "-$_" => $args->{$_}) : () }
qw/from to name/);
# NOTE: if there are no hits, `ccm relate -show' exits with status 1,
# but produces no output on either stdout and stderr
return [ ] if $rc == _exitstatus(1) and $out eq "" and $err eq "";
return $self->set_error($err || $out) unless $rc == 0;
my (@result, $from, $to);
foreach (split(/\Q$RS\E/, $out)) # split into records
{
next unless length($_); # skip empty leading record
my @cols = split(/\Q$FS\E/, $_, -1); # don't strip empty trailing fields
# first $ncol_from columns are the "from" part;
# avoid to parse "from" part more than once if "from => ..." was specified
my @cols_from = splice @cols, 0, $ncol_from;
$from = $self->_parse_query_result($want_from, \@cols_from, $want_row_object)
unless $args->{from} && $from;
# next column is the name of the relation; trim whitespace
(my $name = shift @cols) =~ s/^\s+|\s+$//g;
# next $ncol_to columns are the "to" part;
# avoid to parse "to" part more than once if "to => ..." was specified
my @cols_to = splice @cols, 0, $ncol_to;
$to = $self->_parse_query_result($want_to, \@cols_to, $want_row_object)
unless $args->{to} && $to;
# last column is the create_time of the relation; trim whitespace
(my $create_time = shift @cols) =~ s/^\s+|\s+$//g;
push @result,
{
from => $from,
to => $to,
name => $name,
create_time => $create_time,
};
}
return \@result;
}
sub project_tree
{
my $self = shift;
_usage(@_, 1, undef, '\\%options, @projects');
my ($options, @projects) = @_;
$options = {} unless defined $options;
croak(__PACKAGE__.qq[::project_tree: argument 1 ("options") must be a HASH ref: $options])
unless ref $options eq "HASH";
my %wanted = %$options; # make a copy, because we're modifying it below
my $mark_projects = delete $wanted{mark_projects};
$wanted{pathsep} ||= VCS::CMSynergy::Client::_pathsep;
my $omit_rx = (delete $wanted{omit_top_dir}) && qr/^.*?\Q$wanted{pathsep}\E/;
# NOTE: all other options are passed thru to traverse()
# (and get checked there)
my (%tree, $tag); # referenced in closure below
$wanted{wanted} = sub
{
# skip projects unless "mark_projects" is in effect
return if $_->is_project && !$mark_projects;
# store into %tree with relative workarea pathname as the key
# NOTE: VCS::CMSynergy::Traversal::path() has the same
# value when invoked for a project and its top level
# directory; the "||=" below makes sure we dont't overwrite
# the project entry when "mark_projects" is in effect
my $path = VCS::CMSynergy::Traversal::path();
$path =~ s/$omit_rx// or next if $omit_rx;
@projects == 1 ? $tree{$path} : $tree{$path}->[$tag] ||= $_;
};
for ($tag = 0; $tag < @projects; $tag++)
{
my $proj = $projects[$tag];
$proj = $self->project_object($proj) unless ref $proj;
$proj->traverse(\%wanted) or return;
}
return \%tree;
}
sub project_diff
{
my $self = shift;
_usage(@_, 4, 4, '\\%options, $old_project, $new_project, $differ');
my ($arg_options, $old_project, $new_project, $differ) = @_;
$arg_options = {} unless defined $arg_options;
croak(__PACKAGE__.qq[::project_diff: argument 1 ("options") must be a HASH ref: $arg_options])
unless ref $arg_options eq "HASH";
my %options = %$arg_options; # make a copy, so we can't inadvertently modify it
my $hide_sub_trees = delete $options{hide_sub_trees};
# FIXME lift this hardcoded restriction:
# we must also adjust the regex below (to extract dirname from $path)
$options{pathsep} = "/";
my $tree = $self->project_tree(\%options, $old_project, $new_project);
$differ->start($old_project, $new_project) if $differ->can("start");
# NOTE: the hiding of subtrees depends on an ordering of keys %tree
# that sorts "foo/bar/quux" _after_ "foo/bar"
my %hidden; # directory paths of deleted/added dirs
foreach my $path (sort keys %$tree)
{
my ($old, $new) = @{ $tree->{$path} };
if (!defined $new)
{
# only report the root of a deleted sub tree?
if ($hide_sub_trees)
{
$hidden{$path}++ if $old->is_dir;
(my $dirname = $path) =~ s:/[^/]*$::;
next if $hidden{$dirname};
}
$differ->deleted($path, $old);
}
elsif (!defined $old)
{
# only report the root of an added sub tree?
if ($hide_sub_trees)
{
$hidden{$path}++ if $new->is_dir;
(my $dirname = $path) =~ s:/[^/]*$::;
next if $hidden{$dirname};
}
$differ->added($path, $new);
}
elsif ($old ne $new)
{
$differ->changed($path, $old, $new);
}
else
{
$differ->identical($path, $old) if $differ->can("identical");
}
}
return $differ->can("finish") ? $differ->finish : undef;
}
sub get_attribute
{
my $self = shift;
_usage(@_, 2, 2, '$attribute_name, $file_spec');
my ($name, $file_spec) = @_;
my ($rc, $out, $err) = $self->_ccm(qw/attribute -show/, $name, $file_spec);
return $out if $rc == 0;
return if ($err || $out) =~ /Attribute .* does not exist on object/;
return $self->set_error($err || $out);
}
sub set_attribute
{
my $self = shift;
_usage(@_, 3, 3, '$attribute_name, $file_spec, $value');
my ($name, $file_spec, $value) = @_;
# try "ccm attribute -modify ..." first
my ($rc, $out, $err) = $self->_ccm_attribute(
-modify => $name, -value => $value, $file_spec);
# if this fails because the attribute is inherited,
# try "ccm attribute -force -create ..."
if ($rc != 0 && ($err || $out) =~ /Attribute .* is inherited/)
{
# determine attribute's type
my $type = $self->list_attributes($file_spec)->{$name}
or return $self->set_error(
"oops: attribute $name on `$file_spec' seems inherited, but doesn't show with `ccm attr -la'");
($rc, $out, $err) = $self->_ccm_attribute(
-create => $name, -value => $value, -type => $type, -force => $file_spec);
}
return $value if $rc == 0;
return $self->set_error($err || $out);
}
# helper method (used for "ccm attr -modify" and "ccm attr -force -create")
sub _ccm_attribute
{
my ($self, @args) = @_; # @args must contain ..., -value => $value, ...
# squeeze -value => $value from @args
my $value;
for (my $i = 0; $i < @args; $i++)
{
next unless $args[$i] =~ /^-(?:v|value)$/;
(undef, $value) = splice @args, $i, 2;
last;
}
croak(__PACKAGE__.qq[::_ccm_attribute: mssing argument "-value"])
unless defined $value;
my @cmd = ("attribute", @args);
if ($value eq "")
{
# Setting a text attribute to an empty string is a real PITA:
# - CM Synergy will launch text_editor, even if "-v ''" was specified
# - if the temporary file containing the attribute's value is empty
# after the editor exits, CM Synergy prompts with:
# Result of edit is an empty attribute.
# Confirm: (y/n) [n]
# the following doesn't work on Windows (CCM seems to read
# the confirmation answer directly from CON:, _not_ from stdin)
croak(__PACKAGE__."::_ccm_attribute: setting a text attribute to an empty string is not supported on Windows")
if is_win32;
return $self->_ccm_with_option(
text_editor => $^O eq 'MSWin32' ?
qq[cmd /c echo off > $self->{"%filename"}] : #/
qq[$Config{cp} /dev/null $self->{"%filename"}],
@cmd, { in => \"y\n" });
}
if (($self->{coprocess} && (length($value) > 1600 || $value =~ /["\r\n]/))
|| (is_win32 && (length($value) > 100 || $value =~ /[%<>&"\r\n]/)))
{
# Use ye olde text_editor trick if $value may cause problems
# (depending on execution mode and platform) because its
# too long or contains unquotable characters or...
return $self->ccm_with_text_editor($value, @cmd);
}
return $self->_ccm(@cmd, -value => $value);
}
sub create_attribute
{
my $self = shift;
_usage(@_, 3, undef, '$name, $type, $value, @file_specs');
my ($name, $type, $value, @file_specs) = @_;
croak(__PACKAGE__.'::create_attribute: argument 3 (value) must be defined')
unless defined $value;
my ($rc, $out, $err) = $self->_ccm_attribute(
-create => $name, -value => $value, -type => $type, @file_specs);
return $self->set_error($err || $out) unless $rc == 0;
return 1;
}
sub delete_attribute
{
my $self = shift;
_usage(@_, 1, undef, '$name, @file_specs');
my ($name, @file_specs) = @_;
return scalar $self->ccm(qw/attribute -delete/, $name, @file_specs);
}
sub copy_attribute
{
my $self = shift;
_usage(@_, 3, undef, '{ $name | \\@names }, [ \\@flags, ] $from_file_spec, $to_file_spec...');
my ($name, @file_specs) = @_;
$name = join(':', @$name) if UNIVERSAL::isa($name, 'ARRAY');
my @flags = UNIVERSAL::isa($file_specs[0], 'ARRAY') ?
map { "-$_" } @{ shift @file_specs } : ();
return scalar $self->ccm(qw/attribute -copy/, $name, @flags, @file_specs);
}
sub list_attributes
{
my $self = shift;
_usage(@_, 1, 1, '$file_spec');
my $file_spec = shift;
my ($rc, $out, $err) = $self->_ccm(qw/attribute -la/, $file_spec);
return $self->set_error($err || $out) unless $rc == 0;
# NOTE: regex works for both classic mode and web mode
my %attrs = $out =~ /^(\S+) \s+ \(? (\S+?) [\s)]/gmx;
return \%attrs;
}
sub property
{
my $self = shift;
_usage(@_, 2, 2, '{ $keyword | \@keywords }, $file_spec');
my ($keyword_s, $file_spec) = @_;
if (UNIVERSAL::isa($keyword_s, 'ARRAY'))
{
return $self->_property($file_spec, $keyword_s, 0);
}
else
{
my $row = $self->_property($file_spec, [ $keyword_s ], 0) or return;
return $row->{$keyword_s};
}
}
sub _property
{
my ($self, $file_spec, $keywords, $want_row_object) = @_;
my $want = _want($want_row_object, $keywords);
my $format = $RS . join($FS, values %$want) . $FS;
my ($rc, $out, $err) =
$self->_ccm(qw/properties -nf -format/, $format, $file_spec);
return $self->set_error($err || $out) unless $rc == 0;
my (undef, $props) = split(/\Q$RS\E/, $out, -1);
my @cols = split(/\Q$FS\E/, $props, -1); # don't strip empty trailing fields
return $self->_parse_query_result($want, \@cols, $want_row_object);
}
sub cat_object
{
my $self = shift;
_usage(@_, 1, 2, '$object [, $destination]');
my $want_return = @_ == 1;
my ($object, $destination) = @_;
croak(__PACKAGE__.qq[::cat_object: argument 1 (object) must be a VCS::CMSynergy::Object: $object])
unless UNIVERSAL::isa($object, "VCS::CMSynergy::Object");
my $out;
$destination = \$out if $want_return;
my ($rc, undef, $err) = $self->_ccm(
cat => $object, { out => $destination, binmode_stdout => 1 });
return $self->set_error($err || "`ccm cat $object' failed") unless $rc == 0;
return $want_return ? $out : 1;
}
sub types
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/show -types/);
return $self->set_error($err || $out) unless $rc == 0;
return split(/\n/, $out);
}
sub migrate_auto_rules
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/show -migrate_auto_rules/);
return $self->set_error($err || $out) unless $rc == 0;
return map { [ split(/ /, $_) ] } split(/\n/, $out);
}
sub ls
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/ls/, @_);
return $self->set_error($err || $out) unless $rc == 0;
# filter out messages that a file has been implicitly synced
return [ grep { !/^\tUpdating database/ } split(/\n/, $out) ];
}
sub ls_arrayref
{
my $self = shift;
_usage(@_, 1, undef, '$file_spec, @keywords');
my $file_spec = shift;
return $self->_ls($file_spec, \@_, ROW_ARRAY);
}
sub ls_hashref
{
my $self = shift;
_usage(@_, 1, undef, '$file_spec, @keywords');
my $file_spec = shift;
return $self->_ls($file_spec, \@_, ROW_HASH);
}
sub ls_object
{
my $self = shift;
_usage(@_, 0, 1, '[ $file_spec ]');
my $file_spec = shift;
$file_spec = '.' unless defined $file_spec;
return $self->_ls($file_spec, [], ROW_OBJECT);
}
sub _ls
{
my ($self, $file_spec, $keywords, $row_type) = @_;
my $want = _want($row_type == ROW_OBJECT, $keywords);
my $format = $RS . join($FS, values %$want) . $FS;
my ($rc, $out, $err) = $self->_ccm(qw/ls -format/, $format, $file_spec);
return $self->set_error($err || $out) unless $rc == 0;
# filter out messages that a file has been implicitly synced
$out =~ s/^\tUpdating database.*?(?:\n|\z)//m;
my @result;
foreach (split(/\Q$RS\E/, $out)) # split into records
{
next unless length($_); # skip empty leading record
my @cols = split(/\Q$FS\E/, $_, -1); # don't strip empty trailing fields
my $row = $self->_parse_query_result($want, \@cols, $row_type == ROW_OBJECT);
push @result, $row;
}
if ($row_type == ROW_ARRAY)
{
$_ = [ @$_{@$keywords} ] foreach @result;
}
return \@result;
}
sub set
{
my $self = shift;
_usage(@_, 0, 2, '[$option [, $value]]');
my ($option, $value) = @_;
if (@_ == 0)
{
my ($rc, $out, $err) = $self->_ccm(qw/set/);
return $self->set_error($err || $out) unless $rc == 0;
my %options;
while ($out =~ /^(\S+) = (.*)$/gm)
{
$options{$1} = $2 eq "(unset)" ? undef : $2;
}
return \%options;
}
my ($rc, $out, $err);
my $old_value;
# no need to get old value if we are called in void context
if (defined wantarray)
{
my ($rc, $out, $err) = $self->_set($option);
return $self->set_error($err || $out) unless $rc == 0;
$old_value = $out;
}
if (@_ == 2)
{
my ($rc, $out, $err) = $self->_set($option, $value);
return $self->set_error($err || $out) unless $rc == 0;
}
return $old_value;
}
sub _set
{
my ($self, $option, $new_value) = @_;
if (@_ == 2)
{
my ($rc, $out, $err) = $self->_ccm(set => $option);
$out = undef if $rc == 0 && $out eq "(unset)";
return ($rc, $out, $err);
}
if (@_ == 3)
{
my ($rc, $out, $err) = defined $new_value ?
$self->_ccm(set => $option, $new_value) :
$self->_ccm(unset => $option);
return ($rc, $out, $err);
}
return _error("wrong number of arguments");
}
# helper: save value of $option, set it to $new_value,
# call _ccm(@args), restore $option; returns ($rc, $out, $err)
# (usually the return value from _ccm(@args) except there were errors
# in setting the option)
sub _ccm_with_option
{
my ($self, $option, $new_value, @args) = @_;
my ($rc, $out, $err);
WITH_OPTION:
{
($rc, $out, $err) = $self->_set($option);
last WITH_OPTION unless $rc == 0;
my $old_value = $out;
($rc, $out, $err) = $self->_set($option, $new_value);
last WITH_OPTION unless $rc == 0;
my @result = $self->_ccm(@args);
($rc, $out, $err) = $self->_set($option, $old_value);
last WITH_OPTION unless $rc == 0;
($rc, $out, $err) = @result;
}
return ($rc, $out, $err);
}
# helper: write text to temporary file and return its name
# BEWARE: may re-use the same temporary file (deleted on script exit)
sub _text_to_tempfile
{
my ($self, $text) = @_;
my $fh;
if ($self->{_tempfile})
{
open $fh, "> $self->{_tempfile}"
or return $self->set_error(qq[can't open temp file "$self->{_tempfile}": $!]); #'
}
else
{
($fh, $self->{_tempfile}) = tempfile(UNLINK => 1)
or return $self->set_error(qq[can't create temp file: $!]); #'
}
print $fh $text;
close $fh;
return $self->{_tempfile};
}
# helper: implements ye olde text_editor trick for ccm commands
# that would interactively open an editor in order to let the user modify
# some (text) value; ccm_with_text_editor writes $text_value
# to a temporary file, then calls ccm_with_option with
# text_editor="cp temporary_file %filename" and returns its results
# calls $self->_ccm(@args).
sub ccm_with_text_editor
{
my ($self, $text, @args) = @_;
my $tempfile = $self->_text_to_tempfile($text) or return;
# NOTE:
# (1) $Config{cp} is "copy" on Win32, but CMSynergy doesn't invoke
# the command processor on Windows when executing user
# callbacks like "text_editor"; thus "shell" builtins like "copy"
# (and redirection) won't work in user callbacks; hence
# prefix it with "cmd /c" (use "/b" to get a binary copy
# and "/y" to overwite files without prompting)
# (2) $tempfile is safe wrt cygwin, because $Config{cp} is
# a cygwin program ("/usr/bin/cp") on cygwin.
my ($rc, $out, $err) = $self->_ccm_with_option(
text_editor => $^O eq 'MSWin32' ?
qq[cmd /c copy /b /y "$tempfile" $self->{"%filename"}] : #/
qq[$Config{cp} '$tempfile' $self->{"%filename"}],
@args);
return $self->set_error($err || $out) unless $rc == 0;
return wantarray ? ($rc, $out, $err) : 1;
}
__PACKAGE__->_memoize_method(dcm_delimiter => sub
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/dcm -show -delimiter/);
return $self->set_error($err || $out) unless $rc == 0;
return $out;
});
__PACKAGE__->_memoize_method(dcm_database_id => sub
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm(qw/dcm -show -database_id/);
return $self->set_error($err || $out) unless $rc == 0;
return $out;
});
sub dcm_enabled { shift->dcm_database_id ne ""; }
__PACKAGE__->_memoize_method(default_project_instance => sub
{
my $self = shift;
return $self->version >= 6.3 && $self->dcm_enabled ?
$self->dcm_database_id . $self->dcm_delimiter . '1' : '1';
});
sub _projspec2objectname
{
my ($self, $project) = @_;
$project .= ':project:' . $self->default_project_instance
unless $project =~ /:project:/;
return $project;
}
# generic wrapper for undefined method "foo":
# $ccm->foo(@args)
# gets turned into
# $ccm->ccm("foo", @args)
# in fact, we create a method `foo' on the fly with this definition
sub AUTOLOAD
{
my ($this) = @_;
our $AUTOLOAD;
# NOTE: the fully qualified name of the method has been placed in $AUTOLOAD
my ($class, $method) = $AUTOLOAD =~ /^(.*)::([^:]*)$/;
return if $method eq 'DESTROY';
# we don't allow autoload of class methods
croak(qq[Can't locate class method "$method" via class "$class"]) #'
unless ref $this;
$Debug && $this->trace_msg(qq[autoloading method "$method"\n], 5);
# create the new method on the fly
no strict 'refs';
*{$method} = sub
{
my $self = shift;
my ($rc, $out, $err) = $self->_ccm($method, @_);
return wantarray ? ($rc, $out, $err) : 1 if $rc == 0;
return $self->set_error($err || $out, undef, 0, $rc, $out, $err);
};
# call it w/o pushing a new stack frame (with same parameters)
goto &$method;
}
# test whether session is still alive (without causing an exception)
sub ping
{
my ($rc) = shift->_ccm(qw/delimiter/);
return $rc == 0;
}
# $ccm->object(objectname) => VCS::CMSynergy::Object
# $ccm->object(name, version, cvtype, instance) => VCS::CMSynergy::Object
sub object
{
my $self = shift;
croak(__PACKAGE__."::object: invalid number of arguments" .
"\n usage: \$ccm->object(\$name, \$version, \$cvtype, \$instance)" .
"\n or \$ccm->object(\$objectname)")
unless @_ == 1 || @_ == 4;
return VCS::CMSynergy::Object->new($self, @_) if @_ == 4;
my $objectname = shift;
return VCS::CMSynergy::Object->new($self, $1, $2, $3, $4)
if $objectname =~ /$self->{objectname_rx}/;
return $self->set_error("invalid objectname `$objectname'");
}
# convenience methods to get the base model object etc
# NOTE: base_model should actually be determined from attribute "active_model"
# of "default-1:admin:AC" (the value is an old-style fullname,
# but I've never seen anything else than "base/model/base/1").
sub base_model { $_[0]->object(qw(base 1 model base)); }
sub base_admin { $_[0]->object(qw(base 1 admin base)); }
sub dcm_admin { $_[0]->object(qw(dcm 1 admin dcm)); }
sub cs_admin { $_[0]->object(qw(cs 1 admin 1)); }
sub cvtype { $_[0]->object($_[1], qw(1 cvtype base)); }
sub attype { $_[0]->object($_[1], qw(1 attype base)); }
# FIXME: instead of implementing the inverse function to the
# ACcent method "displayname" of folder/task/problem objects, one could use
# $self>query_object("query_function('$displayname')");
# but query functions like folder() didn't appear before CCM 6.x;
sub _displayname2object
{
my ($self, $name, $cvtype, $format, $subsys) = @_;
# displayname is either <number> (for a local object)
# or <dbid><dcm_delimiter><number> (for a foreign object)
if ($self->dcm_enabled)
{
$self->{dcm_prefix_rx} ||= do { my $rx = quotemeta($self->dcm_delimiter); qr/$rx/; };
my @parts = split($self->{dcm_prefix_rx}, $name);
if (@parts == 2) { ($subsys, $name) = @parts; }
else { $subsys = $self->dcm_database_id; }
}
return $self->object(sprintf($format, $name), "1", $cvtype, $subsys);
}
# get folder/task/problem/... object from displayname (without querying Synergy)
sub folder_object # folder('id')
{
$_[0]->_displayname2object($_[1], qw/folder %s probtrac/);
}
sub task_object # task('id')
{
$_[0]->_displayname2object($_[1], qw/task task%s probtrac/);
}
sub cr_object # cr('id')
{
$_[0]->_displayname2object($_[1], qw/problem problem%s probtrac/);
}
sub baseline_object # baseline('id')
{
$_[0]->_displayname2object($_[1], qw/baseline %s 1/);
}
sub project_object
{
$_[0]->object($_[0]->_projspec2objectname($_[1]));
}
# $ccm->object_other_version(object, version) => VCS::CMSynergy::Object
# new Object with same name/cvtype/instance as OBJECT, but version VERSION
sub object_other_version
{
my $self = shift;
_usage(@_, 2, 2, '$object, $other_version');
my ($object, $other_version) = @_;
return $self->object($object->name, $other_version, $object->cvtype, $object->instance);
}
# $ccm->object_from_cvid(cvid) => VCS::CMSynergy::Object
sub object_from_cvid
{
my $self = shift;
_usage(@_, 1, undef, '$cvid, @keywords');
my $cvid = shift;
return $self->_property("\@=$cvid", \@_, 1);
# NOTE: if the cvid doesn't exist, "ccm property ..." has exit code 0, but
# "Warning: Object version representing type does not exist." on stderr
}
# $ccm->object_from_proj_ref($path, $proj_spec) => VCS::CMSynergy::Object
sub object_from_proj_ref
{
my $self = shift;
_usage(@_, 2, undef, '{ $path | \\@path_components }, $proj_spec, @keywords');
my ($path, $proj_spec) = splice @_, 0, 2;
$path = join(VCS::CMSynergy::Client::_pathsep, @$path) if ref $path;
return $self->_property("$path\@$proj_spec", \@_, 1);
# NOTE/FIXME: no error if path isn't bound? possible errors:
# Specified project not found in database: '$self'
# Object version could not be identified from reference form: '$path'
}
1;