#---------------------------
# vss_synch.pl
#
# perl script to synchronize a sourcesafe
# project (destination/prj) with another (source/prj).
# Do so by:
# a) sharing into the destination any items that have been added to the source
# b) removing from the destination any items that have been deleted from the destination
#
# blame: steve hardy
# shardy@@differentchairs.com

#---------------------------

############################
# set this to point at your copy of the vss commandline executable
# (my version of perl doesn't like embedded spaces here...)
my $ss_pgm = "D:\\temp\\vss6\\ss.exe";

############################
# set this to the username and password of the priveleged sourcesafe user
# this user needs delete privelege in the destination project, and at least
# read privelege on the source project.
# This will, of course, present a security problem if users can see the
# password value. This potential breach could be elimintated by running this
# script in a different security context from the user/client, and, for example,
# storing/retrieving the password in the environment of that separate
# security context.
my $ssuser = "steveh";

############################
# ssdir is a magic variable that tells ss.exe where to find your srcsafe.ini
# (set accordingly)
$ENV{ssdir} = "D:\\v6\\Program Files\\Microsoft Visual Studio\\Common\\VSS";

my $ss_errorthreshold=100;
my $tempdir = $ENV{"TEMP"};


# main: invoke synch function

# synchVSSPrj($synch_dest, $synch_src, $prj);
# Example:
# The following invocation would synch up $/FooBuild/Bar with $/FooSandbox/Bar
# vss_synch.pl $/FooBuild $/FooSandBox Bar

synchVSSPrj(@ARGV);

# main: end




#-------
# Occasionally, the vss cli will spit out an undocumented error message "Error
# reading from file". Its probability of occurance seems to correlate with
# increased network traffic. Often, waiting a few seconds and trying again will
# clear up the problem.
# Herein, I assume the message gets written to stderr.
#-------
sub checked_system
    {
    my $cmdarg = shift @_;
    my $sserrfile = "$tempdir\\sserrmsg.tmp";
    my $done = 0;
    my $loopct = 0;
    my $sleeptime = 4;
    my $maxloop = 5;
    my $result = 0;
    my ($FileRdErr, $OtherErr);

    for ($loopct = 0; !$done && $loopct<$maxloop; $loopct++)
        {
        $FileRdErr = 0;
        $OtherErr = 0;
        $result = system( "$cmdarg 2>$sserrfile" );
        if ($ss_errorthreshold <= $result)
            {
            if (open(SSERR,$sserrfile))
                {
                while (<SSERR>)
                    {
                    if (/Error reading from file/)
                        {
                        print($_);
                        $FileRdErr = 1;
                        }
                    elsif ( /[^\s]+/ ) #nonblank line
                        {
                        chomp $_;
                        system("echo $_>>$tempdir\\ss_syserr.log");
                        $OtherErr = 1;
                        }
                    }
                if ($FileRdErr)
                    {
                    sleep($sleeptime);
                    }
                elsif ($OtherErr)
                    {
                    $done = 1;
                    }
                close SSERR;
                }
            else # no stderr text
                {
                print("Warning: Error occurred with no stderr output.");
                }
            }
        else # command succeeded
            {
            $done = 1;
            }
        }
    return $result;
    }


#-------
# if we redirect sourcesafe (stdout) output to a file, sourcesafe does us the
# misfavor of word wrapping the line at somewhere before col 80. To make the
# output parsable, we must avoid this by explictly sending output to a
# temporary file using a command line option.
#-------
sub UnwrappedResult
	{
	my $sstmpfile = "$tempdir\\SS.OUT";
	my ($cmdarg, $outlist) = @_;

	system( "if exist $sstmpfile del $sstmpfile" );
	checked_system( "$ss_pgm $cmdarg -y$ssuser -o$sstmpfile" );
	if (open(SSTMP, "<$sstmpfile"))
		{
		@$outlist = <SSTMP>;
		close(SSTMP);
		}
	}

#-------
# synchronizes two sourcesafe projects
#
# any subprojects and files that don't show up in dest gets shared into dest,
# and anything in dest that doesn't show up in src is removed from dest.
#-------
sub synchVSSPrj
	{
	my $result = 0;
	my ($synch_dest, $synch_src, $prj) = @_;

	if ( 3 != $#_+1 )
		{
		print "synch: wrong number of arguments...";
		$result = 1;
		}
	else
		{
		# validate args
		@b = `$ss_pgm dir -y$ssuser -f- \"$synch_dest\"`;
		if ($? >= $ss_errorthreshold)
			{
			print "synch: $synch_dest doesn't exist...\n";
			$result = 2;
			}
		else
			{
			@a = `$ss_pgm dir -y$ssuser -f- \"$synch_src/$prj\"`;
			if ($? >= $ss_errorthreshold)
				{
				print "synch: $synch_src/$prj doesn't exist...\n";
				$result = 3;
				}
			else
				{
				if (0 != sharenewitems($synch_dest, $synch_src, $prj ))
					{
					$result = 4;
					}
				elsif (0 != removedelitems($synch_dest, $synch_src, $prj ))
					{
					$result = 5;
					}
				}
			}
		}
	return $result;
	}

#-------
#return nonzero if prj is successfully recovered.
#-------
sub recoverprj
	{
	my $prjname = shift @_;
	my $result = 0;

	if (0==system("$ss_pgm dir -d \"$prjname\" -y$ssuser >nul 2>&1"))
		{
		if (0==system("$ss_pgm recover \"$prjname\" -g- -y$ssuser >nul 2>&1"))
			{
			$result = 1;
			}
		}
	return $result;
	}


#-------
# check to see if a linked copy of file ($fname) has been deleted in the
# destination project ($destprj).
# If so, recover the deleted file and return nonzero.
# Otherwise, return zero.
#-------
sub recoverlinkedfile
	{
	my ($destprj, $srcprj, $fname) = @_;
	my $result = 0;
	my (@a, $b);

	UnwrappedResult( "links \"$srcprj/$fname\"", \@a);

	# Scan linked files
	LINK:
	foreach $b (@a) # linked file,
		{
		if ($b =~ s/\s*(.*?)\s*\($fname is deleted in this project\).*/$1/is)
			{
			if ( lc($b) eq lc($destprj) )
				{
				print "RECOVERING: ";
				if (0==system("$ss_pgm recover \"$destprj/$fname\" -g- -y$ssuser "))
					{
					$result = 1;
					}
				last LINK;
				}
			}
		elsif ($b =~ s/\s*(.*?)\s*$/$1/is)
			{
			# exact undeleted match of file, so no need to continue
			# (assume undeleted entrys preceed deleted entrys in links list)
			if ( lc($b) eq lc($destprj) )
				{
				last LINK;
				}
			}
		}
	return $result;
	}

#-------
# sharenewitems is passed a destination, a source, and a project. If the source
# project is not found in the destination project, share the source project files
# implicitly or explicitly. Recurse on each subproject in source project.
# [return nonzero on error]
#-------

sub sharenewitems
	{
	my ($dest, $src, $prj) = @_;
	my (@a, $b);
	my $result = 0;

	print "+";

	#if not exist dest/prj, share
	@a = `$ss_pgm DIR -f- \"$dest/$prj\" -y$ssuser 2>nul`;

	# if dest project does not exist, and there was no deleted copy to recover
	if ($? >= $ss_errorthreshold && !recoverprj("$dest/$prj"))
		{
		# share this dir only. Files shared implicitly
		if ($ss_errorthreshold <=
		system( "$ss_pgm cp -y$ssuser \"$dest\" >nul 2>&1" ))
			{
			$result = 1;
			print "\ncp failed\n";
			}
		else
			{
			system( "$ss_pgm share -r -g- -c- -I-N -y$ssuser \"$src/$prj\" >nul 2>&1" );
			}
		}
	else # dest project exists
		{
		#share new files (but first, recover existing files)

		UnwrappedResult("$ss_pgm DIR \"$src/$prj\"", \@a);

		FILE:
		foreach $b (@a) # linked file,
			{
			if ( $b =~ /\$/ ) # any dir has "$" prepended
				{
				next FILE;
				}
			elsif ( $b =~ /^\s*$/ ) # blank line at end of files
				{
				last FILE;
				}
			else
				{
				chomp $b;
				recoverlinkedfile("$dest/$prj","$src/$prj", $b);
				}
			}
		if ($ss_errorthreshold <=
		system("$ss_pgm cp -y$ssuser \"$dest/$prj\" >nul 2>&1"))
			{
			print "\nCP failed\n";
			$result = 3;
			}
		else
			{
			system("$ss_pgm share -y$ssuser -g- \"$src/$prj/*.*\" -c- >nul 2>&1");
			}

		#--------
		# AT THIS POINT, could verify that all src files are linked to dest...
		# (but it would cost)
		#--------

		# recurse on each subproject in source

		UnwrappedResult( "dir -f- \"$src/$prj\"", \@a );
		# For each project find the subprojects:
		# ignore leading white space
		# ignore the project itself (indicated by / in name),
		# ignore plain files (indicated by no $ in name)
		# strip off the $ in the subprojects located and recurse.
		PROJECT:
		foreach $b (@a) # subprj in src/prj,
			{
			if ( $b =~ s!^\s*\$([^/].*)!$1!)
				{
				chomp $b;
				$result = sharenewitems("$dest/$prj", "$src/$prj", $b);
				}
			if (0!=$result)
				{
				last PROJECT;
				}
			}
		}
	return $result;
	}


#-------
# removedelitems is passed a destination, a source, and a project. It
# #deletes files and sub projects from destination if they no longer
# exist in source.
# NOTE that this will silently fail if it tries to delete an item within a
# directory that already has a deleted item with the same name
# [return nonzero on error]
#-------

sub removedelitems
	{
	my ($dest, $src, $prj) = @_;
	my (@a,$b);
	my $result = 0;

	print "-";

	#remove deleted files

	UnwrappedResult("dir \"$dest/$prj\"", \@a);
	FILE: foreach $b (@a) #subproject in dest/prj
		{
		chomp( $b );
		next FILE if ($b =~ /\$\/.*/); # skip the project selected (name has $/)
		last FILE if ($b =~ /^$/); # blank line => end of items
		last FILE if ($b =~ /No items found under/);
		if ($b !~ /\$/) # not a subproject (so must be a file)
			{
			if ($ss_errorthreshold <=
			checked_system( "$ss_pgm dir -y$ssuser \"$src/$prj/$b\" >nul" ))
				{
				checked_system("$ss_pgm delete -y$ssuser -I-N \"$dest/$prj/$b\"");
				}
			}
		}

	#remove deleted directories

	UnwrappedResult("dir -f- \"$dest/$prj\"", \@a);
	PRJ: foreach $b (@a)
		{
		chomp( $b );
		next PRJ if ($b =~ /\$\/.*/); # skip the project selected (name has $/)
		last PRJ if ($b !~ /\$.*/); #skip non-projects (skip files at end)
		last PRJ if ($b =~ /No items found under/);
		if ($b =~ s/\$(.*)/$1/) #find sub-projects and remove leading $
			{
			if ($ss_errorthreshold <=
			checked_system( "$ss_pgm dir -y$ssuser -f- \"$src/$prj/$b\">nul" ))
				{
				#delete empty destination sub-project directory
				checked_system("$ss_pgm delete -y$ssuser -I-N \"$dest/$prj/$b\"");
				}
			else
				{
				#recurse on destination sub-projects
				removedelitems("$dest/$prj", "$src/$prj", "$b");
				}
			}
		}
	return $result;
	}