SVN::S4 - Wrapper for Subversion

  use SVN::S4;

# See copyright, etc in below POD section.
######################################################################

package SVN::S4;
require 5.006_001;
use File::Find;
use File::Spec;
use Cwd;

use Carp;
use Data::Dumper;
use SVN::Client;
# Our stuff
use SVN::S4::CatOrMods;
use SVN::S4::Config;
use SVN::S4::Debug qw (DEBUG is_debug);
use SVN::S4::FixProp;
use SVN::S4::Getopt;
use SVN::S4::Info;
use SVN::S4::Path;
use SVN::S4::Update;
use SVN::S4::ViewSpec;
use SVN::S4::QuickCommit;
use SVN::S4::Scrub;
use SVN::S4::Snapshot;
use SVN::S4::WorkProp;
use strict;

######################################################################
#### Configuration Section

our $VERSION = '1.053';

# SVN::Client methods
#       $ctx->add($path, $recursive, $pool);
#       $ctx->blame($target, $start, $end, \&receiver, $pool);
#       $ctx->cat(\*FILEHANDLE, $target, $revision, $pool);
#       $ctx->checkout($url, $path, $revision, $recursive, $pool);
#       $ctx->cleanup($dir, $pool);
#       $ctx->commit($targets, $nonrecursive, $pool);
#       $ctx->copy($src_target, $src_revision, $dst_target, $pool);
#       $ctx->delete($targets, $force, $pool);
#       $ctx->diff($diff_options, $target1, $revision1, $target2, $revision2, $recursive,
#                 $ignore_ancestry, $no_diff_deleted, $outfile, $errfile, $pool);
#       $ctx->export($from, $to, $revision, $force, $pool);
#       $ctx->import($path, $url, $nonrecursive, $pool);
#       $ctx->log($targets, $start, $end, $discover_changed_paths, $strict_node_history,
#                 \&log_receiver, $pool);
#       $ctx->ls($target, $revision, $recursive, $pool);
#       $ctx->merge($src1, $rev1, $src2, $rev2, $target_wcpath, $recursive, $ignore_ancestry,
#                 $force, $dry_run, $pool);
#       $ctx->mkdir($targets, $pool);
#       $ctx->move($src_path, $src_revision, $dst_path, $force, $pool);
#       $ctx->propget($propname, $target, $revision, $recursive, $pool);
#       $ctx->proplist($target, $revision, $recursive, $pool);
#       $ctx->propset($propname, $propval, $target, $recursive, $pool);
#       $ctx->relocate($dir, $from, $to, $recursive, $pool);
#       $ctx->resolved($path, $recursive, $pool);
#       $ctx->revert($paths, $recursive, $pool);
#       $ctx->revprop_get($propname, $url, $revision, $pool);
#       $ctx->revprop_list($url, $revision, $pool);
#       $ctx->revprop_set($propname, $propval, $url, $revision, $force, $pool);
#       $ctx->status($path, $revision, \&status_func, $recursive, $get_all, $update, $no_ignore, $pool);
#       $ctx->switch($path, $url, $revision, $recursive, $pool);
#       $ctx->update($path, $revision, $recursive, $pool)
#       $ctx->url_from_path($target, $pool); or SVN::Client::url_from_path($target, $pool);
#       $ctx->uuid_from_path($path, $adm_access, $pool);
#       $ctx->uuid_from_url($url, $pool);

######################################################################
#### Constants
our %WCSTAT_STRINGS = (
    $SVN::Wc::Status::none => 'none',
    $SVN::Wc::Status::unversioned => 'unversioned',
    $SVN::Wc::Status::normal => 'normal',
    $SVN::Wc::Status::added => 'added',
    $SVN::Wc::Status::missing => 'missing',
    $SVN::Wc::Status::deleted => 'deleted',
    $SVN::Wc::Status::replaced => 'replaced',
    $SVN::Wc::Status::modified => 'modified',
    $SVN::Wc::Status::merged => 'merged',
    $SVN::Wc::Status::conflicted => 'conflicted',
    $SVN::Wc::Status::ignored => 'ignored',
    $SVN::Wc::Status::obstructed => 'obstructed',
    $SVN::Wc::Status::external => 'external',
    $SVN::Wc::Status::incomplete => 'incomplete',
);
our %WCSTAT_LETTERS = (
    $SVN::Wc::Status::none		=> ' ',
    $SVN::Wc::Status::unversioned	=> '?',
    $SVN::Wc::Status::normal		=> ' ',
    $SVN::Wc::Status::added		=> 'A',
    $SVN::Wc::Status::missing		=> '!',
    $SVN::Wc::Status::deleted		=> 'D',
    $SVN::Wc::Status::replaced		=> 'R',
    $SVN::Wc::Status::modified		=> 'M',
    $SVN::Wc::Status::merged		=> 'G',
    $SVN::Wc::Status::conflicted	=> 'C',
    $SVN::Wc::Status::ignored		=> 'I',
    $SVN::Wc::Status::obstructed	=> '!', #?
    $SVN::Wc::Status::external		=> 'X',
    $SVN::Wc::Status::incomplete 	=> '!', #?
);
our %WCKIND_STRINGS = (
    $SVN::Node::none => 'none',
    $SVN::Node::file => 'file',
    $SVN::Node::dir => 'dir',
    $SVN::Node::unknown => 'unknown',
);

######################################################################
#### Creators

sub new {
    my $class = shift;
    my $self = {# Overridable by user
		quiet => 0,
		debug => is_debug,
		dryrun => undef,
		revision => undef,  # default rev for viewspec operations
		s4_binary => "s4",
		svn_binary => "svn",   # overridden by command line or env variable
		#		       # spaces separate arguments, not part of command path
		viewspec_file => "Project.viewspec",
		state_file => ".svn/s4_state",
		rev_on_date_cache => {},   # empty hash ref
		parse_viewspec_include_depth => 0,
		viewspec_vars => {}, # empty hash ref
		void_url => undef,   # cached copy of the URL of the void dir
		# Internals
		#_client => undef,
		#_pool => undef,
		_file_in_repo => {},
		@_};
    # Copy all environment variables into viewspec_vars. Later the viewspec
    # "set" command will either use them or override them.
    foreach (keys %ENV) {
        $self->{viewspec_vars}->{$_} = $ENV{$_};
    }
    my %client_params = %{$self};
    $self->{_client} = new SVN::Client
	(auth => [SVN::Client::get_simple_provider(),
	         SVN::Client::get_username_provider()],
	 %{$self});
    $self->{_pool} = SVN::Pool->new_default;
    bless ($self, $class);
    return $self;
}

sub args_to_params {
    my %args = (@_);
    my %outargs;
    $outargs{quiet}	= $args{"--quiet"}	if defined $args{"--quiet"};
    $outargs{dryrun}	= $args{"--dry-run"}	if defined $args{"--dry-run"};
    return %outargs;
}

######################################################################
#### Accessors

sub client { return $_[0]->{_client}; }
sub debug { return $_[0]->{debug}; }
sub quiet { return $_[0]->{quiet}; }
sub pool { return $_[0]->{_pool}; }

######################################################################
#### Methods

sub open {
    my $self = shift;
}

# remove ./ from the front of a filename
sub clean_filename {
    my $self = shift;
    my $filename = shift;
    $filename .= "";  # Important - converts non-string to string
    $filename =~ s%^\./%%;  # Sometimes results in errors
    # Multiple slashes in pathname (foo//bar) works for many purposes,
    # but svn::client says:
    #   perl: subversion/libsvn_subr/path.c:113: svn_path_join: Assertion `is_canonical (base, blen)' failed.
    $filename =~ s%(?<!:)//+%/%g;  # Doesn't replace :// URLs
    # Remove slash at end
    $filename =~ s%/$%%;
    return $filename;
}

sub abs_filename {
    my $self = shift;
    my $filename = $self->clean_filename(shift);
    return $filename if !$self->is_file_local(filename=>$filename);  # Ignore URLs
    $filename = getcwd if $filename eq '.';
    $filename = getcwd."/".$filename if $filename !~ m%^/%;
    foreach (1..100) {
	# You may have to call readlink several times to resolve all the
	# symlinks, but I didn't want any chance of an infinite loop, so I chose
	# an arbitrary limit of calling readlink 100 times.
        my $try = readlink $filename;
	last if (!defined $try);
	DEBUG "replace filename $filename with readlink filename $try\n" if $self->debug;
	# We need to allow a symlink of just "foo -> bar", note bar has no dir name
	$filename =~ s!/[^/]*$!!;  # basedir(filename)
	$filename = File::Spec->rel2abs($try,$filename);
	DEBUG "    new filename $filename\n" if $self->debug;
    }
    $filename =~ s!/$!! if $filename ne "/";   # Svn gets upset at trailing /'s
    return $filename;
}

# Wait N seconds for a certain file or directory to appear
# This is useful when you have created something on one NFS machine
# and you need to read it on another.
sub wait_for_existence {
    my $self = shift;
    my %params = (#path=>,
                  timeout=>20,
                  @_);
    my $max=$params{timeout};
    (my $parent = $params{path}) =~ s!(.*)/[^/]+$!$1!;
    foreach (1..$max) {
	# In theory, this should make NFS reread the directory
	{ mkdir $parent, 0777; }
	return 1 if (-d $params{path});
	DEBUG "Waiting for $params{path} to appear from file server\n" if $self->debug;
	die "s4: %Error: after $max seconds, the directory $params{path} is still not present." if $_==$max;
	sleep 1;
    }
}

# call system function, and gripe if it returns nonzero exit status.
sub run {
    my $self = shift;
    if (ref $_[0] eq 'ARRAY') {
	# dereference if needed, so that you can pass in either a list
	# or a reference to a list.
        @_ = @{$_[0]};
    }
    DEBUG "+ '", join("' '",@_), "'\n" if $self->debug;
    local $! = undef;
    system @_;
    my $status = $?; my $msgx = $!;
    if (!$self->debug) {
	# Generally: Don't print a message, svn already did.
	if ($status == -1) {
	    exit(255);
	} elsif ($status & 127) {
	    print "%Error: child died with signal %d, %s coredump\n",
	       ($? & 127),  ($? & 128) ? 'with' : 'without';
	    exit(254);
	} elsif ($status != 0) {
	    exit ($status >> 8);
	}
    }
    ($status == 0) or croak "%Error: Command Failed $status $msgx, stopped";
}

sub run_s4 {
    my $self = shift;
    my @list = ($self->{s4_binary});
    push @list, "--debugi", $self->debug if $self->debug;
    push @list, @_;
    $self->run (@list);
}

sub run_svn {
    my $self = shift;
    my @list = (split(/\s+/,$self->{svn_binary}), @_);
    $self->run (@list);
}

sub hide_all_output {
    my $self = shift;
    if ($self->debug) {
        DEBUG "hide_all_output: If I wasn't in debug mode, I would hide stdout and stderr now.\n";
	return;
    }
    CORE::open(SAVEOUT, ">& STDOUT") or croak "%Error: Can't dup stdout, stopped";
    CORE::open(SAVEERR, ">& STDERR") or croak "%Error: Can't dup stderr, stopped";
    if (0) {close(SAVEOUT); close(SAVEERR);}        # Prevent unused warning
    CORE::open(STDOUT, "/dev/null") or croak "%Error: Can't redirect stdout, stopped";
    CORE::open(STDERR, ">& STDOUT") or croak "%Error: Can't dup stdout, stopped";
}

sub restore_all_output {
    my $self = shift;
    if ($self->debug) {
        DEBUG "restore_all_output: If I wasn't in debug mode, I would restore stdout and stderr now.\n";
	return;
    }
    # put STDOUT,STDERR back where they belong
    CORE::open (STDOUT, ">&SAVEOUT");
    CORE::open (STDERR, ">&SAVEERR");
}

sub read_viewspec_state {
    my $self = shift;
    my %params = (#path=>
                  @_);
    my $file = "$params{path}/$self->{state_file}";
    undef $self->{prev_state};
    $self->hide_all_output();
    eval {
      our $VAR1;
      DEBUG "Requiring file $file\n" if $self->debug;
      require $file;
      $self->{prev_state} = $VAR1;
    };
    $self->restore_all_output();
    return $self->{prev_state};
}

sub save_viewspec_state {
    my $self = shift;
    my %params = (#path=>
                  @_);
    my $state_file = "$params{path}/$self->{state_file}";
    my $state = {
      viewspec_hash => $self->{viewspec_hash},
      viewspec_managed_switches => $self->{viewspec_managed_switches},
    };
    CORE::open (OUT, ">$state_file") or die "s4: %Error: $! writing $state_file";
    print OUT "# S4 State File\n";
    print OUT Dumper($state);
    print OUT "1;  # so that require of this file will work\n";
    close OUT;
}

sub clear_viewspec_state {
    my $self = shift;
    my %params = (#path=>
                  @_);
    my $state_file = "$params{path}/$self->{state_file}";
    unlink $state_file;
}

######################################################################
#### Information retrieval

# file_url(filename=>FILE)
# Is FILE known by subversion?  If so return its URL, else undef.
sub file_url {
    my $self = shift;
    my %params = (#filename =>
                  assert_exists=>1,
		  @_);
    DEBUG "\tfile_url $params{filename}\n" if $self->debug;
    my $filename = $self->abs_filename($params{filename});
    DEBUG "absolute filename = $filename\n" if $self->debug;
    $self->open();
    return undef if $filename =~ m!\.old($|/)!;
    $self->hide_all_output();
    my $url;
    my $error = 1;
    eval {
	$url = $self->client->url_from_path($filename, $self->pool);
	$error = 0;
    };
    $self->restore_all_output();
    if ($params{assert_exists} && $error) {
        die "s4: %Error: file_url: could not find url for path $filename";
    }
    DEBUG "url is $url\n" if $self->debug;
    return $url;
}

sub file_root {
    my $self = shift;
    if (!$self->{_root}) {
	my %params = (#filename =>
		      @_);
	DEBUG "\tfile_root $params{filename}\n" if $self->debug;
	my $filename = $self->abs_filename($params{filename});
	DEBUG "absolute filename = $filename\n" if $self->debug;
	$self->open();
	my $root;
	$self->hide_all_output();
	$self->client->info($filename, undef,
			    $self->is_file_local(filename=>$filename)?undef:'HEAD',
			    sub {
				my ($file, $info, $pool) = @_;
				$root = $info->repos_root_URL;
			    }, 0);
	$self->restore_all_output();
	$root or die "s4: %Error: No SVN root found for $filename\n";
	DEBUG "\tfile_root $params{filename} -> $root\n" if $self->debug;
	$self->{_root} = $root;
    }
    return $self->{_root};
}

sub is_file_local {
    my $self = shift;
    my %params = (#filename =>
		  @_);
    return ($params{filename} !~ m!://!);
}

sub is_file_personal {
    my $self = shift;
    my %params = (#filename =>
		  user => $ENV{USER},
		  @_);
    # Is file owned by specified user?
    DEBUG "\tsvn_file_personal $params{filename}\n" if $self->debug;
    my $filename = $self->clean_filename($params{filename});
    $self->open();
    my $status;
    $self->client->status($filename, "WORKING",
			  sub {
			      $status = $_[1];
			  },
			  0, 1, 0, 0);
    return undef if !$status;

    # Did the current user add it?
    my $added = $status->text_status == $SVN::Wc::Status::added;
    #print "Added\n" if $added;
    return 1 if $added;

    # Is it by the same author?
    my $entry = $status->entry;
    #print "LA ",$entry->cmt_author(),"\n";
    return 1 if $entry->cmt_author() eq $params{user};

    return undef;  # Nope.
}

# Test if file is in repository.
# The only thing that's tricky about this is not printing an error
# or crashing if the file is NOT present.  We redirect output to /dev/null.
sub is_file_in_repo {
    my $self = shift;
    my %params = (#url=>,
                  revision=>'HEAD',
                  @_);
    my $url = $params{url};
    if ($self->{_file_in_repo}{$params{revision}}{$url}) {  # Memoized result
	DEBUG "is_file_in_repo with url='$url' YES-Memoized\n" if $self->debug;
	return 1;
    }
    DEBUG "is_file_in_repo with rev='$params{revision}' url='$url'\n" if $self->debug;
    $self->hide_all_output();
    my $exists = 0;
    eval {
	# ."" needed to make sure stringification occurs, as SWIG won't do so
	my $proplist = $self->client->proplist($url, $params{revision}.'', 0);
	DEBUG "proplist returned, so the url must have existed\n" if $self->debug;
	$exists = 1;
    };
    $self->restore_all_output();
    $self->{_file_in_repo}{$params{revision}}{$url} = $exists;
    return $exists;
}

sub known_file_in_repo {
    my $self = shift;
    my %params = (#url=>,
                  revision=>'HEAD',
                  @_);
    $self->{_file_in_repo}{$params{revision}}{$params{url}} = 1;
}

# Given a date string and url, find the svn revision that was current at that time.
# If you pass in "HEAD" instead of a date string, it will return the head rev.
sub rev_on_date {
    my $self = shift;
    my %params = (date=>'HEAD',
                  #url=>,
		  @_);
    my $date = $params{date};
    my $cached = $self->{rev_on_date_cache}{$date};
    return $cached if $cached;

    my $url = $params{url}."";
    if (!SVN::S4::Path::isURL($params{url})) {
	$url = $self->file_url(filename=>$url);
    }
    if (!$url) {
	# If url is a file that doesn't exist, you can get undef $url.
	# If you pass the undef into revprop_list it will segfault.
	die "s4: %Error: rev_on_date was called with a bad file or url: $params{url}";
    }
    $self->ensure_valid_rev_string ($date);
    DEBUG "about to call revprop_list with url=$url rev=$date\n" if $self->debug;
    # Concat with "" makes it into a string, if it's not.
    # gets around TypeError in method 'svn_client_revprop_list', argument 2
    my ($props,$rev) = $self->client->revprop_list($url."", $date, $self->pool);
    if ($rev !~ /[0-9]+/) {
	die "s4: %Error: failed to look up revision number for '$date'";
    }
    if ($rev > 0 && $rev < 9999999999 && $rev =~ /^[0-9]+$/) {
	$self->{rev_on_date_cache}->{$date} = $rev;
        return $rev;
    }
    die "s4: %Error: failed to look up revision number for '$date'";
}

sub rev_of_head {
    my $self = shift;
    my %params = (#url=>,
    		  #path=>,
		  @_);
    my $url_or_path = $params{url} || $params{path};
    die "s4: %Error: rev_of_head called without url or path param. either one is fine" if !$url_or_path;
    return $self->rev_on_date(url=>$url_or_path, date=>"HEAD");
}

sub which_rev {
    my $self = shift;
    my %params = (#s4=>,
		  #revision=>,
		  #url=>,
		  #path=>,
	    	  @_);
    if ($params{revision} && $params{revision} ne 'HEAD') {
	# We must change the string "HEAD" into a specific revision number,
	# or we can end up with a tree with a mix of revisions.
	return $params{revision};
    }
    return $self->rev_of_head(path=>$params{path}) if $params{path};
    return $self->rev_of_head(url=>$params{url})   if $params{url};
    die "s4: %Error: which_rev called without url or path param";
}

# Given a URL in the repository, find the URL of the "void" directory.
# The void directory is an empty directory somewhere above the URL,
# but we don't know exactly where.  Too bad the URL string does not specify
# which parts are UNIX directories and which are SVN repository directories.
# Example with URL svn+ssh://svn.sicortex.com/svn/master/scx1000/trunk/
# - Try URL svn+ssh://svn.sicortex.com/void
# - Try URL svn+ssh://svn.sicortex.com/svn/void
# - Try URL svn+ssh://svn.sicortex.com/svn/master/void
# I decided to start with short URLs and grow them because it finds our
# void dir on the third try.  If I started with long URLs and shrank
# them, on deeper trees it would take more than three tries.
#
# Performance: Takes 1-2 seconds. But I'm not overly concerned because you only
# pay that penalty one time per checkout run, and only if you are using
# viewspecs.
sub void_url {
    my $self = shift;
    my %params = (#url=>,
                  @_);
    DEBUG "void_url url=$params{url}\n" if $self->debug;
    return $self->{void_url} if $self->{void_url};  # use cached copy
    my ($proto,$server,$path) = $params{url} =~ /(.*:\/{2,3})([^\/]+)(\/.*)/;
    die "s4: %Error: could not parse url $params{url}" if !defined $proto || !defined $server || !defined $path;
    my $pathbuild = "$proto$server";
    # I wrote the above regexp so that $path has a slash in front. So the first
    # time through the loop, $pathpart="".
    foreach my $pathpart (split ('/', $path)) {
        $pathbuild .= "/" if $pathpart ne '';
	$pathbuild .= $pathpart;
	my $url = "$pathbuild/void";
	DEBUG "Try URL $url\n" if $self->debug;
	if ($self->is_file_in_repo(url=>$url)) {
	    $self->{void_url} = $url;  # found it! cache for next time.
	    return $url;                # I'm just gonna assume it's a directory
	}
    }
    die "s4: %Error: Could not find void in any URL above $params{url}. To use viewspecs, you must create a top-level directory called void in the SVN repository.\n";
}

sub ensure_valid_rev_string {
    my $self = shift;
    my $rev = shift;
    return if $rev =~ /^[0-9]+$/;		# allow revision number
    return if $rev =~ /^{\d{4}-\d{2}-\d{2}}$/;	# allow {2006-01-01}
    return if $rev eq 'HEAD';			# allow HEAD keyword
    die "s4: %Error: rev argument '$rev' must have the form: r2000 or r{2006-01-01} or HEAD\n";
}

sub ensure_valid_date_string {
    my $self = shift;
    my $date = shift;
    return if $date =~ /^\d{4}-\d{2}-\d{2}$/;	# allow 2006-01-01
    die "s4: %Error: date argument '$date' must have the form: 2006-01-01\n";
}

sub dir_uses_viewspec {
    my $self = shift;
    my $path = shift;

    my $abspath = $self->abs_filename($path);
    my $viewspec = "$abspath/$self->{viewspec_file}";

    # Ignore Viewspec's burried under other (possible) viewspecs
    my $parent_is_svn = (-d "$abspath/../.svn");
    DEBUG "  Note this tree is under another svn tree ($abspath/../.svn)\n" if $parent_is_svn && $self->debug;
    return (!$parent_is_svn && -f $viewspec);
}

######################################################################
#### Properties

sub propget_string {
    my $self = shift;
    my %params = (#filename =>
		  #propname =>
		  dryrun => $self->{dryrun},
		  debug => $self->debug,
		  quiet => $self->{quiet},
		  @_);
    # Return property value for given file/propname
    my $filename = $self->clean_filename($params{filename});
    DEBUG "\tsvn_propget $filename  $params{propname}\n" if $self->debug;

    $self->open();
    my $pl = $self->client->proplist($filename, undef, 0);
    return undef if !$pl;
    foreach my $propitem (@{$pl}) {
	my $propval = $propitem->prop_hash->{$params{propname}};
	return $propval if defined $propval;
    }
    return undef;
}

sub propset_string {
    my $self = shift;
    my %params = (#filename =>
		  #propname =>
		  #propval =>
		  dryrun => $self->{dryrun},
		  quiet => $self->{quiet},
		  @_);
    # Set property name, only if not set yet
    my $filename = $self->clean_filename($params{filename});

    $self->open();
    my $stored = $self->propget_string(%params);
    if (!defined $stored || (($stored ne $params{propval})
			     && "$stored\n" ne $params{propval})) {
	print "    svn propset $params{propname} $filename\n" if !$params{quiet};
	$self->client->propset($params{propname}, $params{propval}, $params{filename}, 0) if !$params{dryrun};
    }
}

######################################################################
#### Package return
1;

######################################################################