File Coverage

blib/lib/VSS.pm

Criterion	Covered	Total	%
statement	3	164	1.8
branch	0	70	0.0
condition	0	9	0.0
subroutine	1	18	5.5
pod			n/a
total	4	261	1.5

package VSS;
$VERSION = '1.0.2';

# --------------------------------------------------------------
#  This is my first module ever, so if it
#  sucks then blame that.
#
#  This module is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
# --------------------------------------------------------------

use strict;
require Exporter;
require Win32::OLE;
require Carp;

our @ISA = qw(Exporter);

sub new {
	my $invocant = shift();
	my $class = ref($invocant) || $invocant;
	$class = bless {
		db_path => undef,
		username => "",
		password => "",
		vss_base => undef,
		debug => 0,

		_vssdb => undef
	}, $class;
	$class->init(@_);
	return $class;
}

sub init {
	my $self = shift();
	my %args = @_;

	foreach (keys %args) {
		if (exists $self->{$_}) {
			$self->{$_} = $args{$_};
		}
		else {
			Carp::croak ("unrecognized vss option $_");
		}
	}

	if (!defined($self->{db_path}))
	{
		my $Registry;
		require Win32::TieRegistry;
		import Win32::TieRegistry ( Delimiter => "/", TiedRef => \$Registry );

		# Work out the DB path from the registry
		$self->{'db_path'} = $Registry->{"CUser/Software/Microsoft/SourceSafe/Current Database"};
		Carp::croak ("No VSS DB path provided and none found in registry. If you have the VSS Shell installed, use the " .
					 "'File->Open SourceSafe Database' menu option with the " .
					 "'Open this database next time...' option to set a default")
			if (!defined($self->{'db_path'}));
		$self->{'db_path'} .= "\\srcsafe.ini";
	}

	$self->{'_vssdb'} = Win32::OLE->new('SourceSafe');
	$self->oleerr();

	$self->{'_vssdb'}->Open($self->{'db_path'}, $self->{'username'}, $self->{'password'});
	$self->oleerr();
}

sub _itemize {
	my ($self, $item) = @_;

	if (!(UNIVERSAL::isa($item, 'Win32::OLE'))) {
		if ($item !~ m/^\$/) {
			$item = $self->{'vss_base'}.$item;
		}

		$item = $self->{'_vssdb'}->VSSItem($item);
		$self->oleerr();
		return ($item);
	}

	if (!(UNIVERSAL::isa($item, 'Win32::OLE'))) {
		return undef;
	}

	return ($item);
}

sub _itemize_name {
	my ($self, $item) = @_;

	if (UNIVERSAL::isa($item, 'Win32::OLE')) {
		return ($item->Spec());
	}

	if ($item !~ m/^\$/) {
		$item = $self->{'vss_base'}.$item;
	}

	return ($item);
}

sub _debug {
	my ($self, $val, $name) = @_;
	return if (!$self->{'debug'});
	if (UNIVERSAL::isa($val, 'Win32::OLE')) {
		print "debug $name is a VSS::Item or similar\n";
	}
	else {
		print "debug: $name is $val\n";
	}
}

sub item_exists {
	my ($self, $named_item) = @_;
	$named_item = $self->_itemize_name($named_item);
	my $err;

	$named_item = $self->{'_vssdb'}->VSSItem($named_item);
	$err = Win32::OLE->LastError();
	if ($err) {
		if ($err =~ m/0x8004d68f/ && $err =~ m/File or project not found/) {
			return 0;
		}
		$self->oleerr();
	}

	return $named_item;
}

sub checkin {
	my ($self, $vss_item, $comment) = @_;
	$vss_item = $self->_itemize($vss_item);

	if (!$vss_item) { Carp::croak ("{VSS::checkin} don't know what $vss_item is"); }

	$vss_item->Checkin($comment);
	$self->oleerr();
	return ($vss_item);
}

sub checkout {
	my ($self, $vss_item, $comment) = @_;
	$vss_item = $self->_itemize($vss_item);

	if (!$vss_item) { Carp::croak ("{VSS::checkout} don't know what $vss_item is"); }

	if ($vss_item->IsCheckedOut()) { return undef; }

	$vss_item->Checkout($comment);
	$self->oleerr();
	return ($vss_item);
}

# does this work?
sub local_file {
	my ($self, $vss_item) = @_;
	my $local_spec;
	$vss_item = $self->_itemize($vss_item);

	if (!$vss_item) { Carp::croak ("{VSS::local_file} don't know what $vss_item is"); }

	$local_spec = $vss_item->LocalSpec();
	$self->oleerr();

	return ($local_spec);
}

# no news is good news
sub share_and_branch {
	my ($self, $from, $to, $autocheckin) = @_;
	my $from = $self->_itemize($from);
	my $to = $self->_itemize($to);

	if (!$from) { Carp::croak ("{VSS::share_and_branch} don't know what $from is"); }
	if (!$to) { Carp::croak ("{VSS::share_and_branch} don't know what $to is"); }

	if ($from->IsCheckedOut()) {
		if ($autocheckin) {
			$self->checkin($from);
		}
		else {
			return($self->_itemize_name($from).' is checked out');
		}
	}

	$self->share($from, $to, 1); # delete if exists

	# refresh $to item
	$self->branch($self->_itemize($self->_itemize_name($to)));

	return 0;
}

sub branch {
	my ($self, $file_item) = @_;
	$file_item = $self->_itemize($file_item);
	if (!$file_item->isa('Win32::OLE')) {
		Carp::croak("{VSS::branch} $file_item is not a valid VSSItem!!");
	}

	$file_item->Branch(); $self->oleerr();
}

sub share {
	my ($self, $from, $to, $delete_if_exists) = @_;
	$from = $self->_itemize($from);
	$to = $self->_itemize_name($to);

	if (!$from->isa('Win32::OLE')) {
		Carp::croak("{VSS::share} $from is not a valid VSSItem!!");
	}

	if ($self->item_exists($to)) {
		if ($delete_if_exists) {
			$self->destroy($to);
		}
		else {
			return "$to exists";
		}
	}

 	# get the parent directory name
	$to =~ s|^(.+)/(?:.*?)?$|$1/|;

	$to = $self->_itemize($to);

	if (!$to->isa('Win32::OLE')) {
		Carp::croak("{VSS::share} $to is not a valid VSSItem!!");
	}

	$to->Share($from); $self->oleerr();
	return 0;
}

sub destroy {
	my ($self, $item) = @_;
	$item = $self->_itemize($item);

	if (!$item->isa('Win32::OLE')) { Carp::croak ("Cannot destory $item!"); }

	$item->Destroy();
	$self->oleerr();
}

sub add {
	my ($self, $vss_dir, $local_file) = @_;
	$vss_dir = $self->_itemize_name($vss_dir);

	if (!-e $local_file) {
		Carp::croak("{VSS::add} $local_file does not exist!");
	}

	$vss_dir = $self->add_directories($vss_dir)->Add($local_file);
	$self->oleerr();
	return ($vss_dir); #it's actually an item.
}

sub add_directories { # ... unless they exist
	my ($self, $dir_path) = @_;
	$dir_path = $self->_itemize_name($dir_path);
	my @all_dirs = split('/', $dir_path);
	my $dir_base = splice (@all_dirs, 0, 1).'/'; # should be $/
  	my $tmp_dir = $dir_base;
  	foreach my $dir (@all_dirs) {
		$tmp_dir .= "$dir/";
		if (!$self->item_exists($tmp_dir)) {
			$self->_debug($dir_base, 'dir_base');
			$self->_itemize($dir_base)->NewSubProject($tmp_dir);
			$self->oleerr();
		}
		$dir_base = $tmp_dir;
	}

	return ($self->_itemize($dir_base));
}

sub update {
	my ($self, $vss_dir, $local_file_name, $local_file_path) = @_;
	($vss_dir = $self->_itemize_name($vss_dir)) =~ s|([^/])$|$1/|;
	my $vss_name = $vss_dir.$local_file_name;

	if (!-e $local_file_path) { Carp::croak ("{VSS::update} $local_file_path does not exist"); }

	if ($local_file_path !~ m/${local_file_name}$/i) {
		Carp::croak ("{VSS::update} $local_file_path does not end with $local_file_name");
	}

	if ($self->item_exists($vss_name)) {
		my $item = $self->checkout($vss_name) || $self->_itemize($vss_name);
		if (!$item) {
			Carp::croak ("{VSS::update} can't use item $item");
		}

		my $localspec = $self->local_file($item);
		if (!$localspec) {
			Carp::croak ("{VSS::update} can't get LocalSpec. All I got was $localspec!");
		}

		require File::Copy;
		File::Copy::copy($local_file_path, $localspec) or
			Carp::croak ("{VSS::update} can't copy $local_file_path to $localspec. $!");

		$self->checkin($item);
		return 1;
	}

	return ($self->add($vss_dir, $local_file_path));
}

sub oleerr {
	my $cache;
	if ($cache = Win32::OLE->LastError()) { Carp::confess("$cache\n"); }
}

1;

__END__