ssphys/test/lib/VssCmd.pm

   1 # Copyright 2004 Ed Price.
   2 #
   3 # This file is part of vss2svn2 (see http://vss2svn2.tigris.org/).
   4 #
   5 # vss2svn2 is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # vss2svn2 is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with vss2svn2; if not, write to the Free Software Foundation,
  17 # Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 package VssCmd;
  20
  21 our $VERSION = '0.5.6';
  22
  23 #
  24
  25 use warnings;
  26 use strict;
  27 use Carp;
  28
  29 sub first(&@);
  30 our(%gErrMatch);
  31
  32
  33 # provides access to real VSS repository.
  34 #
  35 # uses SS.EXE command.
  36
  37 # XXX TODO:
  38 #
  39 #  * consider "-S" or "-S-" to enable/disable "smart mode".
  40 #  * consider "-NL" (long filename mode)
  41 #  * consider all the crazy "-G" Get (et al) options...
  42 #  * use "-C@file" for multiline comments.
  43
  44 #use VssPath;
  45
  46 # required options:
  47 #
  48 #  * vss_dir
  49 #  * vss_user
  50 #
  51 # optional options:
  52 #
  53 #  * vss_pass
  54 #
  55 # XXX TODO: add nowarn, nodebug.
  56 # XXX mostly duplicated from VssOle.pm.
  57 sub new
  58 {
  59     my ($class, %options) = @_;
  60
  61     my $vss_dir = File::Spec->rel2abs($options{vss_dir});
  62     my $vss_log = File::Spec->rel2abs($options{vss_log});
  63
  64     my $self =
  65     {
  66         vss_cmd  => exists $options{vss_cmd} ? $options{vss_cmd} : "ss",
  67         vss_dir  => $vss_dir,
  68         vss_user => $options{vss_user},
  69         vss_pass => exists $options{vss_pass} ? $options{vss_pass} : "",
  70         vss_log  => $vss_log,
  71                 use_tempfiles => 1,
  72     };
  73
  74     bless $self, $class;
  75 }
  76
  77 # creates an empty repository.
  78 #
  79 # currently requires VSS admin tools in PATH:
  80 #
  81 #  * mkss.exe
  82 #  * ddupd.exe
  83 #  * ddconv.exe
  84 #
  85 # note: if vss_dir (as supplied to VssOle->new) does not exist, it will
  86 # be created.  if it does exist, it MUST BE EMPTY.
  87 #
  88 # XXX duplicated from VssOle.pm.
  89 sub create
  90 {
  91     my ($self) = @_;
  92     croak "repository already open" if defined $self->{vss};
  93
  94     my $vss_cmd     = $self->{vss_cmd};
  95     my $vss_dir     = $self->{vss_dir};
  96     my $vss_user    = $self->{vss_user};
  97
  98     # XXX only "admin" seems to work.
  99     $self->WARN ("VSS user besides 'admin' probably wont work")
 100         unless lc($vss_user) eq "admin";
 101
 102     # XXX dont know how to set password.
 103     $self->WARN ("password not supported")
 104         if $self->{vss_pass};
 105
 106     my $srcsafe_ini = $vss_dir . "/srcsafe.ini";
 107     my $users_txt   = $vss_dir . "/users.txt";
 108     my $data_dir    = $vss_dir . "/data";
 109     my $users_dir   = $vss_dir . "/users";
 110     my $user_dir    = $vss_dir . "/users/$vss_user";
 111     my $ss_ini      = $vss_dir . "/users/$vss_user/ss.ini";
 112
 113     # create VSS dir, if necessary
 114     if (not -e $vss_dir)
 115     {
 116         mkdir $vss_dir or croak "error creating VSS dir ($vss_dir): $!";
 117     }
 118     # make sure VSS dir is empty
 119     {
 120         opendir(DH, $vss_dir) or croak "error opening VSS dir ($vss_dir): $!";
 121         my @files = grep { $_ ne "." and $_ ne ".." } readdir(DH);
 122         croak "VSS dir ($vss_dir) not empty" if @files;
 123         closedir(DH);
 124     }
 125
 126     # create srcsafe.ini
 127     open FH, ">$srcsafe_ini" or croak "error opening srcsafe.ini ($srcsafe_ini): $!";
 128     print FH "Data_path = data\n";
 129     print FH "Temp_path = temp\n";
 130     print FH "Users_path = users\n";
 131     print FH "Users_Txt = users.txt";
 132     close FH or warn "error closing srcsafe.ini ($srcsafe_ini): $!";
 133
 134     # create users.txt
 135     open FH, ">$users_txt" or croak "error creating users.txt ($users_txt): $!";
 136     print FH "$vss_user = users\\$vss_user\\ss.ini\n";
 137     close FH or warn "error closing users.txt ($users_txt): $!";
 138
 139     # create users dir, and users/<vss_user>
 140     mkdir $users_dir or croak "error creating users dir ($users_dir): $!";
 141     mkdir $user_dir or croak "error creating user dir ($user_dir): $!";
 142
 143     # create (empty) "ss.ini" file for vss_user.
 144     open FH, ">$ss_ini" or croak "error opening user ss.ini ($ss_ini): $!";
 145     close FH or warn "error closing user ss.ini ($ss_ini): $!";
 146
 147     # create data dir
 148     mkdir $data_dir or croak "error creating data dir ($data_dir): $!";
 149
 150     #
 151     # now populate data dir (the fun part).
 152     #
 153
 154     # 1. create empty VSS repository in version 4 format.
 155     #
 156     # "mkss" adds the following files to $data_dir:
 157     #
 158     #  * um.dat (user management)
 159     #  * aaaaaaaa
 160     #  * aaaaaaaa.a
 161     #  * aaaaaaaa.cnt
 162
 163     $self->_exec ("mkss", $data_dir);
 164
 165     # 2. convert to version 5 format.
 166     #
 167     # "ddupd" prints "File um.dat may be corrupt" (why?)
 168     # and adds a "loggedin" folder.
 169
 170     # XXX that message probably causes non-zero exit status...
 171     eval { $self->_exec ("ddupd", $data_dir); } or
 172         warn "ignoring DDUPD.EXE non-zero exit status";
 173
 174     # 3. convert to version 6 format.
 175     #
 176     # "ddconv" adds all the one-letter folders and some other stuff.
 177
 178     $self->_exec ("ddconv", $data_dir);
 179 }
 180
 181 #
 182 # SS.EXE "subcommand" list (from MSDN):
 183 #
 184 # XXX TODO: which ones do wildcard matching, -R for recursion, etc.
 185 #
 186 # command       priority
 187 # -------       --------
 188 # About         -
 189 # Add           1
 190 # Branch        2
 191 # Checkin       1
 192 # Checkout      -
 193 # Cloak         -
 194 # CP            0 (blocks everything)
 195 # Create        1 (mkdir, essentially?  XXX whats diff b/t project and dir??)
 196 # Decloak       -
 197 # Delete        1
 198 # Deploy        -
 199 # Destroy       2
 200 # Difference    -
 201 # Directory     3 ("ls" basically)
 202 # Filetype      3 (gets/sets whether file is Text vs Binary)
 203 # FindinFiles   -
 204 # Get           1
 205 # Help          -
 206 # History       3
 207 # Label         2
 208 # Links         3
 209 # Merge         3
 210 # Move          1
 211 # Password      -
 212 # Paths         3
 213 # Pin           2
 214 # Project       - (shows "CurrentProject")
 215 # Properties    -
 216 # Purge         2
 217 # Recover       2
 218 # Rename        1
 219 # Rollback      3
 220 # Share         2
 221 # Status        -
 222 # Undocheckout  -
 223 # Unpin         2
 224 # View          -
 225 # Whoami        -
 226 # WorkFold      0 (blocks everything)
 227
 228 # XXX in general maybe better to use hash args, eg:
 229 #
 230 #   recurse => 1,
 231 #   file    => "a.txt",
 232 #   comment => "blah blah", etc.
 233
 234 # ----------
 235 # priority 0
 236 # ----------
 237 #
 238 # CP            0 (blocks everything)
 239 # WorkFold      0 (blocks everything)
 240 #
 241 # note: renamed "CP" to "CurrentProject" to prevent confusion wrt
 242 # 'copy'.
 243
 244 sub CurrentProject {
 245     my ($self, $proj) = @_;
 246     $self->_ss ("CP", $proj);
 247 }
 248
 249 sub WorkFold {
 250     my ($self, $path) = @_;
 251     $path = File::Spec->rel2abs ($path);
 252     $self->_ss ("WorkFold", $path);
 253 }
 254
 255 # ----------
 256 # priority 1
 257 # ----------
 258 #
 259 # Add           1
 260 # Checkin       1
 261 # Create        1 (mkdir, essentially?  XXX whats diff b/t project and dir??)
 262 # Delete        1
 263 # Get           1
 264 # Move          1
 265 # Rename        1
 266
 267 # XXX can this add a dir?  or just a file?
 268 sub Add {
 269     my ($self, $file) = @_;
 270     $self->_ss ("Add", $file);
 271 }
 272
 273 sub Checkin {
 274     my ($self, $file) = @_;
 275     $self->_ss ("Checkin", $file);
 276 }
 277
 278 sub Create {
 279     my ($self, $dir) = @_;
 280     $self->_ss ("Create", $dir);
 281 }
 282
 283 sub Delete {
 284     my ($self, $file) = @_;
 285     $self->_ss ("Delete", $file);
 286 }
 287
 288 sub Dir {
 289     my ($self, $file) = @_;
 290     return $self->_ss ("Dir", $file);
 291 }
 292
 293 sub Get {
 294     my ($self, $file) = @_;
 295     $self->_ss ("Get", $file);
 296 }
 297
 298 sub Move {
 299     my ($self, $src_file, $tgt_dir) = @_;
 300     $self->_ss ("Move", $src_file, $tgt_dir);
 301 }
 302
 303 sub Rename {
 304     my ($self, $old_file, $new_file) = @_;
 305     $self->_ss ("Rename", $old_file, $new_file);
 306 }
 307
 308 # ----------
 309 # priority 2
 310 # ----------
 311 #
 312 # Branch        2
 313 # Destroy       2
 314 # Label         2
 315 # Pin           2
 316 # Purge         2
 317 # Recover       2
 318 # Share         2
 319 # Unpin         2
 320
 321 # ----------
 322 # priority 3
 323 # ----------
 324 #
 325 # Directory     3 ("ls" basically)
 326 # Filetype      3 (gets/sets whether file is Text vs Binary)
 327 # History       3
 328 # Links         3
 329 # Merge         3
 330 # Paths         3
 331 # Rollback      3
 332
 333 # ---------------
 334 # everything else
 335 # ---------------
 336 #
 337 # About         -
 338 # Checkout      -
 339 # Cloak         -
 340 # Decloak       -
 341 # Deploy        -
 342 # Difference    -
 343 # FindinFiles   -
 344 # Help          -
 345 # Password      -
 346 # Project       - (shows "CurrentProject")
 347 # Properties    -
 348 # Status        -
 349 # Undocheckout  -
 350 # View          -
 351 # Whoami        -
 352
 353 #
 354 # internal methods
 355 #
 356
 357 sub _ss
 358 {
 359     my ($self, $verb, @args) = @_;
 360
 361     $ENV{SSDIR} = $self->{vss_dir};
 362
 363     my @other = ();
 364     {
 365         push @other, "-I-Y"; # Yes to all prompts; XXX dubious...
 366         push @other, "-Y" . $self->{vss_user} . "," . $self->{vss_pass};
 367         push @other, "-O" . $self->{vss_log};
 368         #push @other, "-W"; # writable working copy; XXX doesnt work with all commands
 369     }
 370
 371     return $self->_exec ($self->{vss_cmd}, $verb, @args, @other);
 372 }
 373
 374 sub _exec
 375 {
 376     my ($self, @command) = @_;
 377
 378     $self->LOG ("EXEC: @command");
 379     my $ans = system (@command);
 380
 381     # error-checking based on "perldoc -f system".
 382     die "error running '@command': $!" if $ans == -1;
 383     $ans /= 256;
 384     die "error ($ans) from '@command'" if $ans != 0;
 385 }
 386
 387 # logging
 388
 389 sub ERROR {
 390     my ($self, $msg) = @_;
 391     print "# XXX (ERROR) $msg\n";
 392 }
 393
 394 sub WARN {
 395     my ($self, $msg) = @_;
 396     print "# XXX (WARNING) $msg\n" unless $self->{nowarn};
 397 }
 398
 399 sub DEBUG {
 400     my ($self, $msg) = @_;
 401     print "# $msg\n" unless $self->{nodebug};
 402 }
 403
 404 sub LOG {
 405     my ($self, $msg) = @_;
 406     print "# $msg\n";
 407 }
 408
 409
 410 ###############################################################################
 411 #  Initialize
 412 ###############################################################################
 413 sub Initialize {
 414     # see ss method for explanation of this
 415     %gErrMatch = (
 416                     GET    => 'is not an existing filename or project',
 417                     CREATE => 'Cannot change project to',
 418                     CP     => 'Cannot change project to',
 419                  );
 420 }  # End Initialize
 421
 422 sub first(&@) {
 423         my $code = shift;
 424         &$code && return $_ for @_;
 425         return undef;
 426 }
 427
 428
 429 1;