File Coverage

blib/lib/VCS/SnapshotCM/Tools.pm

Criterion	Covered	Total	%
statement	21	259	8.1
branch	0	130	0.0
condition	0	20	0.0
subroutine	7	31	22.5
pod	16	16	100.0
total	44	456	9.6

################################################################################
#
# $Project: /VCS-SnapshotCM $
# $Author: mhx $
# $Date: 2005/04/09 13:36:08 +0200 $
# $Revision: 9 $
# $Snapshot: /VCS-SnapshotCM/0.02 $
# $Source: /lib/VCS/SnapshotCM/Tools.pm $
#
################################################################################
#
# Copyright (c) 2004 Marcus Holland-Moritz. All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
################################################################################

=head1 NAME

VCS::SnapshotCM::Tools - Tools for SnapshotCM Version Control

=head1 SYNOPSIS

  use VCS::SnapshotCM::Tools;

  $vcs = VCS::SnapshotCM::Tools->new;

  $vcs->configure(server => 'scmsrv.mydomain');

  if ($vcs->exists_snapshot(snapshot => '/my-project/Current')) {
    # ...
  }

  # ... and lots more. Use the Source, Luke!

=head1 DESCRIPTION

VCS::SnapshotCM::Tools is a collection of tools to query information
from the SnapshotCM version control system.

SnapshotCM is available from L.

This module is mainly used to implement the functionality required
by the tools L and L. It lacks documentation
as well as lots of possible features. The interface may change in
backwards-incompatible ways. Use at your own risk.

=head1 METHODS

=cut

package VCS::SnapshotCM::Tools;
use strict;
use Carp;
use File::Temp qw( mktemp );
use IO::File;
use Time::Local;
use Data::Dumper;
use vars qw( $VERSION );

$VERSION = do { my @r = '$Snapshot: /VCS-SnapshotCM/0.02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };

=head2 C OPTION =E VALUE, ...

Create a new VCS::SnapshotCM::Tools object. You may pass the
same options as to the L|/"configure"> method.

=cut

sub new
{
  my $class = shift;
  my $self = bless {
    debug    => 0,
    server   => undef,
    project  => undef,
    snapshot => undef,
  }, $class;
  $self->configure(@_);
  $self->_debug(1, "## perl version $] on $^O\n");
  $self->_debug(2, Data::Dumper->Dump([$self], ['self']));
  return $self;
}

=head2 C OPTION =E VALUE, ...

Configures certain properties of a VCS::SnapshotCM::Tools object.

=over 2

=item C =E 0 | 1

Turn debug output on or off.

=item C =E I

Set a default server hostname.

=item C =E I

Set a default project name.

=back

=cut

sub configure
{
  my($self, %prop) = @_;
  for my $p (keys %prop) {
    if (exists $self->{$p}) {
      $self->{$p} = $prop{$p};
    }
    else {
      croak "Unknown property '$p'.";
    }
  }
  return $self;
}

=head2 C

Get workspace mapping information for the current directory.

=cut

sub get_current_mapping
{
  my $self = shift;
  $self->_map_options([], @_);
  my $out = $self->_run("wls -f -M");
  for (@{$out->{stderr}}) {
    /^=/ or last;
    if (/^=+\s*Workspace:\s*(.*?)\s*=\s*/) {
      return $self->get_mapping(name => $1);
    }
  }
  return undef;
}

=head2 C OPTION =E VALUE, ...

Get workspace mapping information.

=cut

sub get_mapping
{
  my $self = shift;
  my $arg = $self->_map_options([qw(server dir snapshot name)], @_);
  my $out = $self->_run("wmap list $arg");
  my %tr = (
    'Workspace Name'   => 'name',
    'Server'           => 'server',
    'Snapshot'         => 'snapshot_path',
    'Mapped Directory' => 'mapped_dir',
    'Text Format'      => 'text_format',
    'Workspace Type'   => 'type',
    'Working Set'      => 'working_set',
  );

  my @rv;
  for (@{$out->{stdout}}) {
    /^\s*([^:]+):\s*(.*?)\s*$/ or next;
    exists $tr{$1} or carp "Unknown wmap property '$1'.\n";
    push @rv, {} if @rv == 0 or exists $rv[-1]{$tr{$1}};
    $rv[-1]{$tr{$1}} = $2;
  }

  @rv or return;

  for (@rv) {
    if (exists $_->{snapshot_path}) {
      ($_->{project}, $_->{snapshot}) = $self->split_snapshot_path($_->{snapshot_path});
    }
  }

  return wantarray ? @rv : $rv[0];
}

=head2 C OPTION =E VALUE, ...

Try to guess the hostname of the SnapshotCM server.

=cut

sub guess_server_hostname
{
  my $self = shift;
  my(undef, %opt) = $self->_map_options([qw(*snapshot)], @_);
  my $out = $self->_run("wmap list");
  my %server;
  for (@{$out->{stdout}}) {
    /Server:\s*(.*?)\s*$/ and $server{$1}++;
  }
  my @servers = keys %server;

  unless (@servers) {
    my $out = $self->_run("sslist -P -t1");
    my @servers = @{$out->{stdout}};
    chomp @servers;
  }

  if (@servers > 1 and exists $opt{snapshot}) {
    for (@servers) {
      $self->exists_snapshot(server => $_, snapshot => $opt{snapshot})
          and return $_;
    }
  }
  return wantarray ? @servers : @servers == 1 ? $servers[0] : undef;
}

=head2 C OPTION =E VALUE, ...

Poorly named method that guesses local hostname
and snapshot properties.

=cut

sub guess_local
{
  my $self = shift;
  my(undef, %opt) = $self->_map_options([qw(*server[d] *snapshot[m])], @_);
  my %rv;

  my $map = $self->get_current_mapping;
  $rv{mapping} = $map if defined $map;

  my @servers = exists $opt{server} ? $opt{server}
                                    : $self->guess_server_hostname;

  for my $server (@servers) {
    my @ss = ($opt{snapshot});
    push @ss, "$map->{project}/$opt{snapshot}" if defined $map;

    for my $snapshot (@ss) {
      next unless $snapshot =~ m! ^/ !x;
      if ($self->exists_snapshot(server => $server, snapshot => $snapshot)) {
        $rv{server} = $server;
        $rv{path}   = $snapshot;
        @rv{qw(project snapshot)} = $self->split_snapshot_path($snapshot);
        return \%rv;
      }
    }
  }

  return undef;
}

=head2 C OPTION =E VALUE, ...

Check if a snapshot exists.

=cut

sub exists_snapshot
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] *snapshot[m])], @_);
  my $snapshot = $self->_expand_snapshot_path($opt{snapshot});
  my $out = $self->_run("sslist $arg -d -H $snapshot");
  for (@{$out->{stdout}}) {
    /^\s*\Q$snapshot\E\s*$/ and return 1;
  }
  return 0;
}

=head2 C OPTION =E VALUE, ...

Get list of snapshots for a project.

=cut

sub get_snapshots
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] *project[md])], @_);
  my $out = $self->_run("sslist $arg -H -R $opt{project}");
  chomp @{$out->{stdout}};
  return @{$out->{stdout}};
}

=head2 C OPTION =E VALUE, ...

Get list of files for a snapshot.

=cut

sub get_files
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md])], @_);
  my $out = $self->_run("wls -Rfpv $arg");
  my %f;
  for (@{$out->{stdout}}) {
    chomp;
    if (m! ^ (.*?) (/?) \[(\d+)\] $ !x) {
      $f{$1} = { type => ($2 ? 'dir' : 'file'),
                 revision => $3 };
    }
    else {
      warn "Cannot parse wls output: $_\n";
    }
  }
  return \%f;
}

=head2 C OPTION =E VALUE, ...

Read a certain revision of a file from a snapshot.

=cut

sub read_file
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md] rev *file)], @_);
  my $out = $self->_run("wco -p -q $arg $opt{file}");
  return @{$out->{stdout}};
}

=head2 C OPTION =E VALUE, ...

Get an IO::File reference to a certain revision of a file from a snapshot.

=cut

sub open_file
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md] rev *file)], @_);
  $self->_open("wco -p -q $arg $opt{file}");
}

=head2 C OPTION =E VALUE, ...

Read the diff between two revisions of a file.

=cut

sub read_diff
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md] rev1=-r{} rev2=-r{} *file)], @_);
  my $out = $self->_run("wdiff $arg $opt{file}");
  return @{$out->{stdout}};
}

=head2 C OPTION =E VALUE, ...

Get an IO::File reference to the diff between two revisions of a file.

=cut

sub open_diff
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md] rev1=-r{} rev2=-r{} *file)], @_);
  $self->_open("wdiff $arg $opt{file}");
}

=head2 C OPTION =E VALUE, ...

Get history information for a file.

=cut

sub get_history
{
  my $self = shift;
  my($arg, %opt) = $self->_map_options([qw(server[md] snapshot[md] *rev1 *rev2 *file ancestors[b]=-A)], @_);
  my $rev = '';
  $rev .=   $opt{rev1}  if exists $opt{rev1};
  $rev .= ":$opt{rev2}" if exists $opt{rev2};
  $rev  = "-r$rev"      if $rev;
  my $out = $self->_run("whist -d $rev $arg $opt{file}") or return undef;

  my($info, @rev) = split /\s* ^ -{20,} $ \s*/mx, join('', @{$out->{stdout}});
  defined $info or return undef;

  my %info = $info =~ /^([^:]+):\s*(.*)$/mg;

  return {
    snapshot    => $info{Snapshot},
    permissions => $info{Permissions},
    current_rev => $info{'Current revision'},
    revisions   => _get_rev_info(@rev),
  };
}

=head2 C PATH

Split a snapshot path into project and snapshot.

=cut

sub split_snapshot_path
{
  my($self, $path) = @_;
  exists $self->{_pcache} or $self->rebuild_project_cache;
  for my $p (@{$self->{_pcache}}) {
    if ($path =~ m! ^ \Q$p->[0]\E / (.+) $ !x) {
      return ($p->[0], $1);
    }
  }
  return ($1, $2) if $path =~ m! ^ (/.*) / ([^/]+) $ !x;
  return ('', $path);
}

=head2 C

Explicitly rebuild the project cache. The project cache is
required for splitting snapshot paths correctly.

=cut

sub rebuild_project_cache
{
  my($self) = @_;
  my @servers = defined $self->{server} ? $self->{server}
                                        : $self->guess_server_hostname;
  my @projects;
  for my $s (@servers) {
    my $out = $self->_run("sslist -h$s -H");
    my @p = @{$out->{stdout}};
    chomp @p;
    push @projects, map { [$_ => $s] } @p;
  }
  $self->{_pcache} = [sort { length $b->[0] <=> length $a->[0] } @projects];
}

sub _map_options
{
  Carp::cluck("Invalid arguments") if @_ % 2;

  my($self, $accept, %opts) = @_;

  $self->_debug(1, "## _map_options([".join(", ", map qq{'$_'}, @$accept)."]".
                   (@_>2 ? ", ".join(", ", map qq{'$_'}, @_[2..$#_]) : '').")\n");

  my $caller = (caller(1))[3];
  my %map = (
    server   => '-h{}',
    dir      => '-D{}',
    rev      => '-r{}',
    snapshot => '-S{}',
    name     => '-N{}',
  );
  my %default = (
    server   => $self->{server},
    project  => $self->{project},
    snapshot => $self->{snapshot},
  );
  my %process = (
    snapshot => sub { $self->_expand_snapshot_path(@_) },
  );

  $self->_debug(2, Data::Dumper->Dump([$self, $accept, \%opts, \%default],
                                      [qw(self accept *opts *default)]));

  my %pass;
  my @arg;
  my $more = 0;
  s/^-// for keys %opts;
  for (@$accept) {
    if ($_ eq '*') { $more++; next }
    # (m)andatory (d)efault (b)oolean
    my($passthrough, $o) = /^(\*?)(\w+)(?:\[([mdb]+)\])?(?:=(.*))?$/
                           or die "Invalid option spec '$_'";
    $map{$o} = $4 if defined $4;
    my %mod = map {($_ => 1)} ($3 || '') =~ /./g;
    unless (exists $opts{$o}) {
      $opts{$o} = $default{$o} if $mod{d} and defined $default{$o};
      unless (exists $opts{$o}) {
        $mod{m} and croak "Missing option '$o' for '$caller'";
        next;
      }
    }
    if ($passthrough) {
      $pass{$o} = delete $opts{$o};
      next;
    }
    my $a = $map{$o} or die "Unsupported option '$o'";
    my $in = delete $opts{$o};
    if (!$mod{b} or $in) {
      $in = $process{$o}->($in) if exists $process{$o};
      $a =~ s/\{\}/$in/g;
      push @arg, $a;
    }
  }
  unless ($more || keys(%opts) == 0) {
    my $invalid = join ", ", map { "'$_'" } keys %opts;
    my $s = keys %opts == 1 ? '' : 's';
    croak "Invalid option$s $invalid for '$caller'";
  }
  my $arg = join ' ', @arg;
  return wantarray ? ($arg, %opts, %pass) : $arg;
}

sub _expand_snapshot_path
{
  my($self, $path) = @_;
  my($project, $snapshot) = $self->split_snapshot_path($path);
  $project ||= $self->{project};
  defined $project or Carp::cluck("Project undefined");
  return defined $project ? "$project/$snapshot" : $snapshot;
}

sub _get_rev_info
{
  my @revisions = @_;
  my %rev;

  for (@revisions) {
    m/
      \A
      ^ Revision: \s* (\d+) \s* .*? \s* (?: Derivation: \s* (.*?) \s* )? $ \s*  # (revision) (derivation)
      ^ Date: \s* ([^;]+) ; \s* Size: \s* (\d+) \s* bytes \s* $            \s*  # (date) (size)
      ^ Author: \s* (.*?) \s* $                                            \s*  # (author)
      ^ Snapshot: \s* (.*?) \s* $                                          \s*  # (snapshot)
      (?: ^ Used \s+ in: \s* (.*? (?: \s* ^\s{8,} .+?)* ) \s* $ )?         \s*  # (used)
      (?: ^ Change: \s* (.*?) \s* $ )?                                     \s*  # (change)
      ^ ([\s\S]+)                                                          \s*  # (comment)
      \Z
    /mx or die "Couldn't match revision output";

    my %r = (
      revision => $1,
      date     => $3,
      size     => $4,
      author   => $5,
      snapshot => $6,
      comment  => $9,
    );

    defined $2 and $r{derivation} = $2;
    defined $7 and $r{used_in}    = [ split /\s{8,}/, $7 ];
    defined $8 and $r{change}     = $8;

    my($Y,$M,$D,$h,$m,$s,$zh,$zm) =
           $r{date} =~ m!(\d+)/(\d+)/(\d+) \s* (\d+):(\d+):(\d+) (?:\s+ [+-](\d{2})(\d{2}))?!x
           or warn("Cannot parse date '$r{date}'");

    $r{time} = timegm($s, $m, $h, $D, $M-1, $Y) - (($zh * 60) + $zm) * 60;

    $r{comment} =~ s/[\r\n]+$//;

    $rev{$r{revision}} = \%r;
  }

  return \%rev;
}

sub _run
{
  my($self, $cmd) = @_;
  my %rv = (error => 0);

  $self->_debug(1, "## run: $cmd\n");

  my $out = mktemp("soutXXXX");
  my $err = mktemp("serrXXXX");
  my $error;

  if (system "$cmd 1>$out 2>$err") {
    $rv{error} = $?;
  }

  if (-f $out) {
    $rv{stdout} = [_slurp($out)];
    unlink $out or carp "Couldn't remove temporary file '$out'";
    if ($self->{debug} >= 2) {
      $self->_debug(2, "1> $_") for @{$rv{stdout}};
    }
  }

  if (-f $err) {
    $rv{stderr} = [_slurp($err)];
    unlink $err or carp "Couldn't remove temporary file '$err'";
    if ($self->{debug} >= 2) {
      $self->_debug(2, "2> $_") for @{$rv{stderr}};
    }
  }

  return \%rv;
}

sub _open
{
  my($self, $cmd) = @_;
  $self->_debug(1, "## open: $cmd\n");
  IO::File->new("$cmd 2>/dev/null |");
}

sub _debug
{
  my($self, $level, @args) = @_;
  if ($self->{debug} >= $level) {
    my $output = join '', @args;
    $output =~ s/^/[$level] /mg;
    print STDERR $output;
  }
}

sub _slurp
{
  my $file = shift;
  my $fh = new IO::File $file or return undef;
  return wantarray ? <$fh> : do { local $/; <$fh> };
}

1;

=head1 COPYRIGHT

Copyright (c) 2004 Marcus Holland-Moritz. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

SnapshotCM is copyright (c) 2000-2003 True Blue Software Company.

=head1 SEE ALSO

See L, L.

=cut