package VCP::Utils::vss ; =head1 NAME VCP::Utils::vss - utilities for dealing with the vss command =head1 SYNOPSIS use VCP::Utils::vss ; =head1 DESCRIPTION A mix-in class providing methods shared by VCP::Source::vss and VCP::Dest::vss, mostly wrappers for calling the vss command. =cut use strict ; use Carp ; use File::Spec ; use File::Temp qw( mktemp ) ; use VCP::Debug qw( :debug ) ; use VCP::Logger qw( lg pr_doing pr_done pr_done_failed ); use VCP::Utils qw( empty start_dir ) ; =head1 METHODS =item ssdir The location of the VSS database, if set in either the SSDIR environment variable or in the source or destination specification. =cut sub ssdir { my $self = shift; defined $self->repo_server ? File::Spec->rel2abs( $self->repo_server, start_dir ) : $ENV{SSDIR}; } =item ssuser The location of the VSS database, if set in either the SSUSER environment variable or in the source or destination specification. =cut sub ssuser { my $self = shift; defined $self->repo_user ? $self->repo_user : $ENV{SSUSER}; } =item ss Calls the vss command with the appropriate vssroot option. TODO: See if we can use two different users to do vss->vss. Not sure if VSS sets the cp and workfold per machine or per user. =cut sub ss { my $self = shift ; my $args = shift ; my $cmd = shift @$args; my $user = $self->repo_user; my @Y_arg; push @Y_arg, "-Y$user" unless empty $user; local $ENV{SSPWD} = $self->repo_password if defined $self->repo_password; local $ENV{SSDIR} = $self->ssdir if defined $self->repo_server; lg "SSDIR=$ENV{SSDIR}"; my @I_arg; push @I_arg, "-I-" unless grep /^-I/, @$args; my @O_arg; ## Forcing VSS to emit to a file with its -O@foo.txt syntax ## prevents it from wrapping at 80 cols. Sigh. my ( $out_ref, $out_fn ); ## ss ignored -O@ on help command if ( $#_ >= 1 && $_[1] && ref $_[1] && lc $cmd ne "help" ) { $out_fn = mktemp( File::Spec->catfile( File::Spec->tmpdir, "vcp_vss_XXXX" ) ); $out_ref = $_[1]; $_[1] = undef; @O_arg = ( "-O\@$out_fn" ); } my $retrying; RETRY: my $ok = eval { $self->run_safely( [ "ss", $cmd, @$args, @Y_arg, @I_arg, @O_arg ], @_ ) ; 1; }; if ( !$ok ) { if ( ! $retrying && $@ eq "UNDOCHECKOUT\n" ) { $self->run_safely( [ "ss", "UndoCheckout", $args->[0], @Y_arg, "-I-Y", "-G-" ], { stderr_filter => qr{ ^(?: \$/.* |File.*not\sfound.* |Continue.* |.*has\schanged.* )\r?\n }xm, } ); $retrying = 1; goto RETRY; } else { die $@; } } if ( $out_ref ) { local *F; open F, "<$out_fn" or die "$!: $out_fn for SS.EXE stdout\n"; if ( ref $out_ref eq "SCALAR" ) { $$out_ref = join "", ; } else { $out_ref->( \*F ); } close F; unlink $out_fn or warn "$! deletign '$out_fn'\n"; } return; } =item throw_undocheckout_and_retry This is called from the stderr_filter for SS.EXE commands that emit a "File ... is checked out by ..." message so that VCP can issue an undocheckout command and retry, like the Recover command. =cut sub throw_undocheckout_and_retry { my $self = shift; die "UNDOCHECKOUT\n"; } =item ss_cp $self->ss_cp( $project ); Changes to a new current project, does not change projects if this is the current project. =cut sub ss_cp { my $self = shift; my ( $new_project ) = @_; return if defined $self->{VSS_CURRENT_PROJECT} && $new_project eq $self->{VSS_CURRENT_PROJECT}; $self->ss( [ "cp", "\$/$new_project" ] ); $self->{VSS_CURRENT_PROJECT} = $new_project; } =item parse_vss_repo_spec parse repo_spec by calling parse_repo_spec, then set the repo_id. =cut sub parse_vss_repo_spec { my $self = shift ; my ( $spec ) = @_ ; $self->parse_repo_spec( $spec ) ; $self->repo_id( "vss:" . $self->repo_server ); }; =item create_vss_workspace Creates a temporary directory. =cut sub create_vss_workspace { my $self = shift ; ## establish_workspace in a directory named "co" for "checkout". This is ## so that VCP::Source::vss can use a different directory to contain ## the revs, since all the revs need to be kept around until the VCP::Dest ## is through with them. my $workspace = $self->tmp_dir; $self->mkdir( $workspace ); } =item get_vss_file_list Retrieves a list of all files and directories under a particular path. We need this so we can tell what dirs and files need to be added. =cut sub _scan_for_files { my $self = shift; my ( $path, $type, $filelist ) = @_; $path = $self->repo_filespec unless defined $path; $path =~ s{^\$?[\\/]*}{}; my $path_re = $self->compile_path_re( $path ); debug "file scan re: $path_re" if debugging ; my $cur_project; for ( @$filelist ) { pr_doing; if ( /^(|No items found.*|\d+ item.*s.*)$/i ) { undef $cur_project; next; } if ( m{^\$/(.*):} ) { $cur_project = $1; ## Catch all project entries, because we may be importing ## to a non-existant project inside a project that exists. if ( length $cur_project ) { ## Add a slash so a preexisting dest project is found. # if ( "$cur_project/" =~ $path_re ) { my $p = $cur_project; # ## Catch all parent projects. This prevents us from # ## creating more than need be. # do { my @state = $self->files->get( [ $p ] ); $self->files->set( [ $p ], @state, "project" ) if ! grep $_ eq "project", @state; # $self->{VSS_FILES}->{$p} = "project"; # } while $p =~ s{/[^/]*}{} && length $p; # } $cur_project .= "/"; } next; } if ( m{^\$(.*)} ) { confess "undefined \$cur_project" unless defined $cur_project; ## A subproject. note here for completeness' sake; it should also ## occur later in a $/foo: section of it's own. my $p = "$cur_project$1"; if ( $p =~ $path_re ) { my @state = $self->files->get( [ $p ] ); $self->files->set( [ $p ], @state, "project" ) if ! grep $_ eq "project", @state; } next; } if ( "$cur_project$_" =~ $path_re ) { my $p = "$cur_project$_"; my @state = $self->files->get( [ $p ] ); ## In VSS, a file may be both deleted and not deleted. So ## we always append the type to a list of types for files. $self->files->set( [ $p ], @state, $type ) if ! grep $_ eq $type, @state; next; } } } sub get_vss_file_list { my $self = shift; my ( $path ) = @_; ## Sigh. I tried passing in $path to the Dir -D command and ## ss.exe whines because $path is rarely a deleted path RATHER ## THAN JUST GIVING ME ALL DELETED FILES UNDER $path!!! ## So, we get all the output and filter it for $path/... ourselves. ## This does have the advantage that we can use full wildcards in ## $path. $self->ss_cp( "" ); pr_doing "scanning VSS for files '$path': ", { Interval => 5, Modulo => 1, }; $self->_scan_for_files( $path, "file", [ do { my $filelist; $self->ss( [qw( Dir -R )], undef, \$filelist ); map { s/[\r\n]//g; $_ } split /^/m, $filelist; } ] ); $self->_scan_for_files( $path, "deleted", [ do { my $filelist; $self->ss( [qw( Dir -R -D)], undef, \$filelist ); map { s/[\r\n]//g; $_ } split /^/m, $filelist; } ] ); pr_done "found " . $self->vss_files, " files"; } =item vss_files @files = $self->vss_files; returns a list of all files (not projects) that get_vss_file_list() loaded. =cut sub vss_files { my $self = shift; ## TODO: allow a pattern. This would let us handle filespecs like ## /a*/b* map $_->[0], grep grep( $_ ne "project", $self->files->get( $_ ) ), $self->files->keys; } ## TODO: DEPRECATED. delete this sub once it's not needed by VCP::Source::vss. sub vss_file { my $self = shift; my ( $path, $value ) = @_; warn caller; confess unless defined $path; for ( $path ) { s{\\}{/}g; s{\/+$}{}; s{\$+}{}g; s{^/+}{}; } if ( @_ > 1 ) { $self->{VSS_FILES}->{$path} = $value; if ( $value ) { my $p = $path; while () { $p =~ s{(^|/)+[^/]+$}{}; last unless length $p || $self->{VSS_FILES}->{$p}; $self->{VSS_FILES}->{$p} = "project"; } } } return exists $self->{VSS_FILES}->{$path} && $self->{VSS_FILES}->{$path}; } =item vss_file_is_deleted Returns 1 if the file is a deleted file. NOTE: in VSS a file may be deleted and not deleted at the same time! Thanks to Dave Foglesong for pointing this out. =cut sub vss_file_is_deleted { my $self = shift; return grep $_ eq "deleted", $self->files->get( [ @_ ] ); } =item vss_file_is_active Returns 1 if the file is an active (undeleted) file. NOTE: in VSS a file may be deleted and active at the same time! Thanks to Dave Foglesong for pointing this out. =cut sub vss_file_is_active { my $self = shift; return grep $_ ne "deleted", $self->files->get( [ @_ ] ); } =head1 COPYRIGHT Copyright 2000, Perforce Software, Inc. All Rights Reserved. This module and the VCP package are licensed according to the terms given in the file LICENSE accompanying this distribution, a copy of which is included in L. =cut 1 ; 1;