vss2svn.pl

   1 #!perl
   2
   3 # vss2svn.pl, Copyright (C) 2004 by Toby Johnson.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 # http://www.gnu.org/copyleft/gpl.html
  15
  16
  17 use warnings;
  18 use strict;
  19
  20 use Getopt::Long;
  21 use Cwd;
  22 use File::Path;
  23 use Text::Wrap;
  24 use Pod::Usage;
  25
  26 use DBD::SQLite;
  27 use DBI;
  28
  29 use Win32::TieRegistry (Delimiter => '/');
  30
  31 our(%gCfg, $VSS, $SVN, $TREE, %USERS,);
  32
  33 # http://www.perl.com/tchrist/defop/defconfaq.html#What_is_the_proposed_operat
  34 sub first(&@);
  35 sub PrintMsg; # defined later
  36
  37 &Vss2Svn::Subversion::Initialize;
  38 &Vss2Svn::VSS::Initialize;
  39
  40 &Regionalize;
  41 &Initialize;
  42 &GiveStartupMessage unless $gCfg{noprompt};
  43 &SetupLogfile;
  44
  45 &CreateDatabase;
  46
  47 &GetProjectTree;
  48 &BuildHistory;
  49 &GiveHttpdAuthMessage unless $gCfg{noprompt};
  50
  51 $gCfg{dbh}->commit;
  52
  53 &SetupSvnProject;
  54 &ImportSvnHistory;
  55
  56 &CloseDatabase;
  57 PrintMsg "\n\n**** VSS MIGRATION COMPLETED SUCCESSFULLY!! ****\n";
  58
  59 close STDERR;
  60 open STDERR, ">&THE_REAL_STDERR"; # yes, we're about to exit, but leaving
  61                                   # STDERR dangling always makes me nervous!
  62
  63 exit(0);
  64
  65
  66 ###############################################################################
  67 #  GetProjectTree
  68 ###############################################################################
  69 sub GetProjectTree {
  70     PrintMsg "\n\n**** BUILDING INITIAL STRUCTURES; PLEASE WAIT... ****\n\n";
  71
  72     $TREE = $VSS->project_tree($gCfg{vssproject},1,1)
  73         or die "Couldn't create project tree for $gCfg{vssproject}";
  74 }
  75
  76 ###############################################################################
  77 #  GiveStartupMessage
  78 ###############################################################################
  79 sub GiveStartupMessage {
  80
  81     my $setdates;
  82     my $datemsg = '';
  83
  84     if ($gCfg{setdates}) {
  85         $setdates = 'yes';
  86         $datemsg = <<"EOMSG";
  87
  88
  89 WARNING: Commit dates can be migrated to a NEW SUBVERSION REPOSITORY only.
  90 You WILL CORRUPT your data if you migrate dates to an existing repository
  91 which is at any other Revision than 0!
  92 EOMSG
  93     } else {
  94         $setdates = 'no';
  95     }
  96
  97     print <<"EOMSG";
  98
  99          ss.exe Found: $gCfg{ssbin}
 100         svn.exe Found: $gCfg{svnbin}
 101           VSS Project: $gCfg{vssproject}
 102        Subversion URL: $gCfg{svnrepo}
 103  Set SVN Commit Dates: $setdates$datemsg
 104
 105 EOMSG
 106
 107     print "Continue with these settings? [Y/n]";
 108     my $reply = <STDIN>;
 109     exit(1) if ($reply =~ m/\S/ && $reply !~ m/^y/i);
 110 }
 111
 112 ###############################################################################
 113 #  SetupLogfile
 114 ###############################################################################
 115 sub SetupLogfile {
 116     # redirect STDERR to logfile
 117     open THE_REAL_STDERR, ">&STDERR";
 118     $gCfg{logfile} = "$gCfg{workbase}/logfile.txt";
 119     open STDERR, ">$gCfg{logfile}"
 120         or die "Couldn't open logfile $gCfg{workbase}/logfile.txt";
 121
 122     # the svn client program outputs to STDOUT; redirect to STDERR instead
 123     open STDOUT, ">&STDERR";
 124
 125     select THE_REAL_STDERR;
 126     $| = 1;
 127     select STDOUT;
 128
 129     # since we redirected STDERR, make sure user sees die() messages!
 130     $SIG{__DIE__} = \&MyDie;
 131 }
 132
 133 ###############################################################################
 134 #  BuildHistory
 135 ###############################################################################
 136 sub BuildHistory {
 137     chdir "$gCfg{importdir}"
 138         or die "Couldn't create working directory $gCfg{importdir}";
 139
 140     PrintMsg "\n\n**** BUILDING VSS HISTORY ****\n\n";
 141
 142     &WalkTreeBranch($TREE, $gCfg{vssproject});
 143 }
 144
 145 ###############################################################################
 146 #  WalkTreeBranch
 147 ###############################################################################
 148 sub WalkTreeBranch {
 149     my($branch, $project) = @_;
 150     PrintMsg "ENTERING PROJECT $project...\n";
 151
 152     my($key, $val, $newproj);
 153     my @branches = ();
 154
 155     foreach $key (sort keys %$branch) {
 156         $val = $branch->{$key};
 157
 158         if (ref($val) eq 'HASH') {
 159             # subproject; create a new branch of the tree
 160
 161             push @branches, {branch => $val, project => "$key"};
 162
 163         } elsif (!ref $val) {
 164             # a scalar, i.e. regular file
 165
 166             &AddFileHistory($project, $key);
 167
 168         }
 169     }
 170
 171     foreach my $subbranch (@branches) {
 172         mkdir $subbranch->{project};
 173         chdir $subbranch->{project}
 174             or die "Could not change to working directory $subbranch->{project}";
 175
 176         ($newproj = "$project/$subbranch->{project}") =~ s://:/:;
 177
 178         &WalkTreeBranch($subbranch->{branch}, $newproj);
 179
 180         chdir '..';
 181     }
 182 }
 183
 184 ###############################################################################
 185 #  AddFileHistory
 186 ###############################################################################
 187 sub AddFileHistory {
 188     my($project, $file) = @_;
 189
 190     # build the revision history for this file
 191
 192     (my $filepath = "$project/$file") =~ s://:/:;
 193     my $filehist = $VSS->file_history("$filepath");
 194     die "Internal error while reading VSS file history for $filepath"
 195         if !defined $filehist;
 196
 197     PrintMsg "   $filepath\n";
 198
 199     foreach my $rev (@$filehist) {
 200         $gCfg{globalCount}++;
 201
 202         $rev->{user} = lc( $rev->{user} );  # normalize usernames to lowercase
 203         $rev->{comment} .= "\n\n$gCfg{comment}" if defined $gCfg{comment};
 204
 205         $rev->{date} =~ s/-//g;
 206         $rev->{time} =~ s/://;
 207
 208         &InsertDatabaseRevision($filepath, $rev);
 209
 210         $USERS{ $rev->{user} } = 1;
 211     }
 212
 213 }
 214
 215 ###############################################################################
 216 #  InsertDatabaseRevision
 217 ###############################################################################
 218 sub InsertDatabaseRevision {
 219     my($filepath, $rev) = @_;
 220
 221     my %data = %$rev; # don't pollute $rev
 222
 223     #quote the text fields
 224     map { $data{$_} = $gCfg{dbh}->quote( $rev->{$_} ) }
 225         qw(date time user comment);
 226
 227     $filepath = $gCfg{dbh}->quote($filepath);
 228
 229     my $cmd = <<"EOSQL";
 230 INSERT INTO
 231     history (
 232         date,
 233         time,
 234         file,
 235         version,
 236         user,
 237         comment,
 238         global_count
 239     )
 240 VALUES (
 241     $data{date},
 242     $data{time},
 243     $filepath,
 244     $data{version},
 245     $data{user},
 246     $data{comment},
 247     $gCfg{globalCount}
 248 )
 249 EOSQL
 250
 251     warn $cmd;
 252
 253     $gCfg{dbh}->do($cmd)
 254         or die "Could not execute DBD::SQLite command";
 255
 256 }  #End InsertDatabaseRevision
 257
 258 ###############################################################################
 259 #  GiveHttpdAuthMessage
 260 ###############################################################################
 261 sub GiveHttpdAuthMessage {
 262    print THE_REAL_STDERR <<"EOTXT";
 263
 264 ATTENTION REQUIRED:
 265   Following is a list of all VSS users who have made updates at any time in the
 266   specified project. In order to preserve the user history during migration to
 267   Subversion, these users must exist in the Subversion authentication file.
 268
 269   Usually, this is done with an Apache "Basic" HTTP authorization file, where
 270   each username is followed by a colon and the hashed password for that user.
 271   A blank password is permissible. Copy and paste the following lines into this
 272   authorization file in order to allow this user history to be migrated.
 273
 274 EOTXT
 275
 276     print THE_REAL_STDERR join("\n", map {"$_:"} sort keys %USERS),
 277     "\n\nPRESS ENTER TO CONTINUE (or enter [q] to quit and start over)...";
 278
 279     my $rep = <STDIN>;
 280
 281     if ($rep =~ /^q/i) {
 282        print THE_REAL_STDERR "\n\nQuitting...\n";
 283        exit(0);
 284     }
 285 }
 286
 287 ###############################################################################
 288 #  SetupSvnProject
 289 ###############################################################################
 290 sub SetupSvnProject {
 291     PrintMsg "\n\n**** SETTING UP SUBVERSION DIRECTORIES ****\n\n";
 292
 293     chdir $gCfg{importdir}
 294         or die "Could not change to directory $gCfg{importdir}";
 295
 296     PrintMsg "   Importing directory structure from Subversion...\n";
 297     $SVN->do('import', '.', '--message "Initial Import"', 0)
 298         or die "Could not perform SVN import of $gCfg{importdir}";
 299
 300     chdir $gCfg{workdir}
 301         or die "Could not change to directory $gCfg{workdir}";
 302
 303     PrintMsg "   Checking out working copy...\n";
 304     $SVN->do('checkout', '', '"."')
 305         or die "Could not perform SVN checkout of $gCfg{importdir}";
 306 }
 307
 308 ###############################################################################
 309 #  ImportSvnHistory
 310 ###############################################################################
 311 sub ImportSvnHistory {
 312     # we will walk the history table in date/time order, GETting from VSS
 313     # as we go. VSS doesn't allow atomic multi-item commits, so we'll detect
 314     # these assuming if the user and comment are the same from one item to the
 315     # next, they were part of the "same" action.
 316
 317     my($row, $upd, $commitinfo);
 318
 319     my %prev = (user => '', comment => '', grain => 0);
 320     my %all = (); # hash of all files ever added
 321     my %thistime = (); # hash of files added on this commit
 322
 323     my $multiple = 0;
 324     my $grain = 0.000001;
 325
 326     PrintMsg "\n\n**** MIGRATING VSS HISTORY TO SUBVERSION ****\n\n";
 327
 328     # date, time, and file fields are formatted to enable sorting numerically
 329     my $cmd = "SELECT * FROM history ORDER BY date, time, file";
 330     my $sth = $gCfg{dbh}->prepare($cmd)
 331         or die "Could not execute DBD::SQLite command";
 332     $sth->execute
 333         or die "Could not execute DBD::SQLite command";
 334
 335 ROW:
 336     while ($row = $sth->fetchrow_hashref) {
 337         $row->{date} =~ s/(....)(..)(..)/$1-$2-$3/;
 338         $row->{time} =~ s/(..)(..)/$1:$2/;
 339         $row->{comment} = ''
 340             if (!exists $row->{comment} || !defined $row->{comment});
 341
 342         PrintMsg "   ($gCfg{commitNumber})File $row->{file}, "
 343             . "$row->{date} $row->{time}...\n";
 344
 345         if (defined $prev{date} &&
 346             ($row->{date} eq $prev{date}) &&
 347             ($row->{user} eq $prev{user}) &&
 348             ($row->{comment} eq $prev{comment}) &&
 349             (!defined $thistime{ $row->{file} })) {
 350
 351             # user and comment are same; this will be multi-item commit
 352             $multiple = 1;
 353
 354         } elsif ($multiple) {
 355             # we're in a multi-item commit but user or comment changed;
 356             # commit previous action
 357             $multiple = 0;
 358             &CommitSvn(1, $prev{comment}, $commitinfo);
 359             undef $commitinfo;
 360             &SetSvnDates(\%prev) if $gCfg{setdates};
 361             %thistime = ();
 362
 363         } elsif (defined $commitinfo) {
 364             # we're not in a multi-item commit and user or comment
 365             # changed; commit the single previous file
 366             $multiple = 0;
 367
 368             &CommitSvn(0, $prev{comment}, $commitinfo);
 369             undef $commitinfo;
 370             &SetSvnDates(\%prev) if $gCfg{setdates};
 371             %thistime = ();
 372         }
 373
 374         if (defined $prev{date} && ($row->{date} ne $prev{date})) {
 375             $grain = 0.000001;
 376
 377             if (defined $commitinfo) {
 378                 # done with this date, so commit what we have so far
 379                 &CommitSvn($multiple, $prev{comment}, $commitinfo);
 380                 undef $commitinfo;
 381
 382                 &SetSvnDates(\%prev) if $gCfg{setdates};
 383                 %thistime = ();
 384
 385                 undef $commitinfo;
 386                 $multiple = 0;
 387             }
 388         }
 389
 390         $upd = $all{ $row->{file} }++;
 391         $commitinfo = &GetVssRevision($row, $upd, \%thistime,);
 392
 393         %prev = (%$row, (grain => $grain));
 394         $grain += 0.000001;
 395
 396     }
 397
 398     if (defined $commitinfo) {
 399         &CommitSvn($multiple, $prev{comment}, $commitinfo);
 400
 401         &SetSvnDates(\%prev) if $gCfg{setdates};
 402         %thistime = ();
 403     }
 404
 405     $sth->finish;
 406
 407 }
 408
 409 ###############################################################################
 410 #  GetVssRevision
 411 ###############################################################################
 412 sub GetVssRevision {
 413     my($row, $upd, $thisRef) = @_;
 414     # Gets a version of a file from VSS and adds it to SVN
 415     # $row is the row hash ref from the history SQLite table
 416     # $upd is true if this is an update rather than add
 417
 418     my $vsspath = $row->{file};
 419
 420     $row->{file} =~ m/^(.*\/)(.*)/
 421         or die "Mangled VSS file path information", join("\n", %$row);
 422     my($path, $file) = ($1, $2);
 423
 424     $path =~ s/$gCfg{vssprojmatch}//
 425         or die "Mangled VSS file path information", join("\n", %$row);
 426     $path =~ s/\/$//; # remove trailing slash
 427
 428     (my $dospath = "$gCfg{workdir}/$path") =~ s/\//\\/g; # use backslashes
 429     $dospath =~ s/\\$//; # remove trailing backslash if $path was empty
 430     $dospath =~ s/\\\\/\\/g; # replace double backslashes with single
 431
 432     my $cmd = "GET -GTM -W -GL\"$dospath\" -V$row->{version} \"$vsspath\"";
 433     $VSS->ss($cmd)
 434         or die "Could not issue ss.exe command";
 435
 436     chdir $dospath
 437         or die "Could not switch to directory $dospath";
 438
 439     if (!$upd) {
 440         $SVN->svn("add \"$file\"")
 441         or die "Could not perform SVN add of $file";
 442     }
 443
 444     my $commitinfo =
 445         { file => $file,
 446           user => $row->{user},
 447           dospath => $dospath,};
 448
 449     $thisRef->{ $row->{file} } = 1;
 450
 451     return $commitinfo;
 452 }
 453
 454 ###############################################################################
 455 #  CommitSvn
 456 ###############################################################################
 457 sub CommitSvn {
 458     my($multiple, $comment, $commitinfo) = @_;
 459
 460     open COMMENTFILE, ">$gCfg{tmpfiledir}/comment.txt"
 461         or die "Could not open $gCfg{tmpfiledir}/comment.txt for writing";
 462     print COMMENTFILE $comment;
 463     close COMMENTFILE;
 464
 465     $multiple? &CommitMultipleItems($commitinfo)
 466         : &CommitSingleItem($commitinfo);
 467
 468     $gCfg{commitNumber}++;
 469
 470 }  #End CommitSvn
 471
 472 ###############################################################################
 473 #  CommitSingleItem
 474 ###############################################################################
 475 sub CommitSingleItem {
 476     my($commitinfo) = @_;
 477
 478     warn "SINGLE COMMIT\n";
 479     chdir $commitinfo->{dospath}
 480         or die "Could not change to directory $commitinfo->{dospath}";
 481
 482     $SVN->{user} = $commitinfo->{user};
 483     $SVN->svn("commit --file \"$gCfg{tmpfiledir}/comment.txt\" "
 484               . "--non-recursive \"$commitinfo->{file}\"")
 485         or die "Could not perform SVN commit on \"$commitinfo->{file}\"";
 486 }
 487
 488 ###############################################################################
 489 #  CommitMultipleItems
 490 ###############################################################################
 491 sub CommitMultipleItems {
 492     my($commitinfo) = @_;
 493
 494     warn "MULTIPLE COMMIT\n";
 495     chdir $gCfg{workdir}
 496         or die "Could not change to directory $gCfg{workdir}";
 497
 498     $SVN->{user} = $commitinfo->{user};
 499     $SVN->svn("commit --file \"$gCfg{tmpfiledir}/comment.txt\" \".\"")
 500         or die "Could not perform SVN commit";
 501 }
 502
 503 ###############################################################################
 504 #  SetSvnDates
 505 ###############################################################################
 506 sub SetSvnDates {
 507     my($info) = @_;
 508
 509     my $grain = sprintf '%0.6f', $info->{grain};
 510     my $svn_date = "$info->{date}T$info->{time}:${grain}Z";
 511
 512     my $cmd = "propset --revprop -rHEAD svn:date $svn_date $gCfg{svnrepo}";
 513     $SVN->svn($cmd)
 514         or die "Could not perform SVN propset of $svn_date on $gCfg{svnrepo}";
 515
 516 }  #End SetSvnDates
 517
 518 ###############################################################################
 519 #  RecursiveDelete
 520 ###############################################################################
 521 sub RecursiveDelete {
 522     my($parent) = @_;
 523     my(@dirs, $dir);
 524
 525     opendir(DIR, $parent);
 526     @dirs = readdir(DIR);
 527     closedir(DIR);
 528
 529     foreach $dir (@dirs) {
 530        if ($dir ne '.' && $dir ne '..') {
 531           &RecursiveDelete("$parent/$dir");
 532        }
 533     }
 534
 535     if (-d $parent) {
 536         rmdir($parent);
 537     }
 538     elsif (-f $parent) {
 539         unlink($parent);
 540     }
 541
 542 }
 543
 544 ###############################################################################
 545 #  PrintMsg
 546 ###############################################################################
 547 sub PrintMsg {
 548     # print to logfile (redirected STDERR) and screen (STDOUT)
 549     warn @_;
 550     print THE_REAL_STDERR @_;
 551 }  #End PrintMsg
 552
 553 ###############################################################################
 554 #  MyDie
 555 ###############################################################################
 556 sub MyDie {
 557     # any die() is trapped by $SIG{__DIE__} to ensure user sees fatal errors
 558     warn @_;
 559     print THE_REAL_STDERR "\n", @_;
 560
 561     (my $logfile = $gCfg{logfile}) =~ s:/:\\:g;
 562     print THE_REAL_STDERR <<"EOERR";
 563
 564 A fatal error has occured. See $logfile for more information.
 565 EOERR
 566     exit(255);
 567 }  #End MyDie
 568
 569 ###############################################################################
 570 #  Initialize
 571 ###############################################################################
 572 sub Initialize {
 573     GetOptions(\%gCfg,'vssproject=s','svnrepo=s','comment=s',
 574                'vsslogin=s','setdates','noprompt','interactive','timebias=i',
 575                'help');
 576
 577     &GiveHelp(undef, 1) if defined $gCfg{help};
 578
 579     defined $gCfg{vssproject} or GiveHelp("must specify --vssproject\n");
 580     defined $gCfg{svnrepo} or GiveHelp("must specify --svnrepo\n");
 581     defined $ENV{SSDIR} or GiveHelp("\$SSDIR not defined");
 582
 583     $gCfg{vssproject} =~ s:/$:: unless $gCfg{vssproject} eq '$/';
 584     $gCfg{vssprojmatch} = quotemeta( $gCfg{vssproject} );
 585
 586     $gCfg{ssbin} = &CheckForExe
 587         ("ss.exe", "the Microsoft Visual SourceSafe client");
 588
 589     $gCfg{svnbin} = &CheckForExe("svn.exe", "the Subversion client");
 590
 591     my $vss_args = {
 592                     interactive => 'Y',
 593                     timebias    => $gCfg{timebias},
 594                    };
 595
 596     if (defined $gCfg{vsslogin}) {
 597         @{ $vss_args }{'user', 'passwd'} = split(':', $gCfg{vsslogin});
 598         warn "\nATTENTION: about to issue VSS login command; if program\n"
 599             . "hangs here, you have specified an invalid VSS username\n"
 600             . "or password. (Press CTRL+Break to kill hung script)\n\n";
 601     }
 602
 603     $VSS = Vss2Svn::VSS->new($ENV{SSDIR}, $gCfg{vssproject}, $vss_args);
 604     $VSS->{_debug} = 1;
 605
 606     $SVN = Vss2Svn::Subversion->new( $gCfg{svnrepo} );
 607     $SVN->{interactive} = 0;
 608     $SVN->{user} = 'vss_migration';
 609     $SVN->{passwd} = ''; # all passwords are blank
 610     $SVN->{_debug} = 1;
 611
 612     %USERS = ( vss_migration => 1, );
 613
 614     $gCfg{globalCount} = 1;
 615     $gCfg{commitNumber} = 1;
 616
 617     $gCfg{workbase} = cwd() . "/_vss2svn";
 618     &RecursiveDelete( $gCfg{workbase} );
 619     mkdir $gCfg{workbase} or die "Couldn't create $gCfg{workbase}";
 620
 621     $gCfg{workdir} = "$gCfg{workbase}/work";
 622     mkdir $gCfg{workdir} or die "Couldn't create $gCfg{workdir}";
 623
 624     $gCfg{importdir} = "$gCfg{workbase}/import";
 625     mkdir $gCfg{importdir} or die "Couldn't create $gCfg{importdir}";
 626
 627     $gCfg{tmpfiledir} = "$gCfg{workbase}/tmpfile";
 628     mkdir $gCfg{tmpfiledir} or die "Couldn't create $gCfg{tmpfiledir}";
 629
 630     $gCfg{dbdir} = "$gCfg{workbase}/db";
 631     mkdir $gCfg{dbdir} or die "Couldn't create $gCfg{dbdir}";
 632
 633     $VSS->{use_tempfiles} = "$gCfg{tmpfiledir}";
 634
 635 }
 636
 637 ###############################################################################
 638 #  Regionalize
 639 ###############################################################################
 640 sub Regionalize {
 641     my $bias = $Registry->{'HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/'
 642                            .'Control/TimeZoneInformation/ActiveTimeBias'} || 0;
 643     {
 644         use integer; # forces Perl to interpret two's-complement correctly
 645         $gCfg{timebias} = hex($bias) + 0;
 646     }
 647
 648 }
 649
 650 ###############################################################################
 651 #  CheckForExe
 652 ###############################################################################
 653 sub CheckForExe {
 654     my($exe, $desc) = @_;
 655
 656     foreach my $dir (split ';', ".;$ENV{PATH}") {
 657         if (-f "$dir\\$exe") {
 658             return "$dir\\$exe";
 659         }
 660     }
 661
 662     my $msg = fill('', '', <<"EOMSG");
 663 Could not find executable '$exe' in your \%PATH\%. Ensure $desc is properly
 664 installed on this computer, and manually add the directory in which '$exe' is
 665 located to your path if necessary.
 666
 667 \%PATH\% currently contains:
 668 EOMSG
 669
 670     die "$msg\n$ENV{PATH}\n";
 671 }
 672
 673 ###############################################################################
 674 #  CreateDatabase
 675 ###############################################################################
 676 sub CreateDatabase {
 677     $gCfg{dbh} = DBI->connect("dbi:SQLite(RaiseError=>1,AutoCommit=>0)"
 678                               . ":dbname=$gCfg{dbdir}/vss2svn.db","","");
 679     my $cmd;
 680
 681     $cmd = <<"EOSQL";
 682 CREATE TABLE history
 683 (
 684     date    char(8)        NOT NULL,
 685     time    char(5)        NOT NULL,
 686     file    varchar(1024)  NOT NULL,
 687     version long           NOT NULL,
 688     user    varchar(256)   NOT NULL,
 689     comment blob           NOT NULL,
 690     global_count    long   NOT NULL
 691 )
 692 EOSQL
 693
 694     $gCfg{dbh}->do($cmd) or die;
 695 }  #End CreateDatabase
 696
 697 ###############################################################################
 698 #  CloseDatabase
 699 ###############################################################################
 700 sub CloseDatabase {
 701     $gCfg{dbh}->commit;
 702     $gCfg{dbh}->disconnect;
 703 }  #End CloseDatabase
 704
 705 ###############################################################################
 706 #  GiveHelp
 707 ###############################################################################
 708 sub GiveHelp {
 709     my($msg, $full) = @_;
 710     $msg .= "\n" if defined $msg;
 711
 712     my $verbose = $full? 2 : 1;
 713
 714     pod2usage(
 715               {
 716                 -message => $msg,
 717                 -verbose => $verbose,
 718                 -exitval => $verbose,  # if user requested --help, go to STDOUT
 719               }
 720              );
 721
 722 }  #End GiveHelp
 723
 724
 725
 726 sub first(&@) {
 727         my $code = shift;
 728         &$code && return $_ for @_;
 729         return undef;
 730 }
 731
 732
 733
 734
 735 ###############################################################################
 736 #                           package Vss2Svn                                   #
 737 ###############################################################################
 738
 739 package Vss2Svn;
 740
 741 require 5.005_62;
 742 use strict;
 743 use warnings;
 744
 745 use File::Path;
 746 use File::Copy;
 747
 748 use Carp;
 749
 750 our $VERSION = '1.00';
 751
 752 ###############################################################################
 753 #  set_user
 754 ###############################################################################
 755 sub set_user {
 756     my($self, $user, $passwd) = @_;
 757
 758     $self->{user} = $user;
 759
 760     {
 761         no warnings 'uninitialized'; # we want to undef passwd if none passed
 762         $self->{passwd} = $passwd unless $passwd eq '';
 763     }
 764
 765 }  # End set_user
 766
 767
 768 1;
 769
 770
 771
 772 ###############################################################################
 773 #                        package Vss2Svn::Subversion                          #
 774 ###############################################################################
 775
 776 package Vss2Svn::Subversion;
 777
 778 require 5.005_62;
 779 use strict;
 780 use warnings;
 781
 782 use base 'Vss2Svn';
 783
 784 sub first(&@) {
 785         my $code = shift;
 786         &$code && return $_ for @_;
 787         return undef;
 788 }
 789
 790 use File::Path;
 791 use File::Copy;
 792
 793 use Cwd;
 794 use Cwd 'chdir';
 795
 796 use Carp;
 797
 798 our(%gInteractiveCmds);
 799
 800 ###############################################################################
 801 #  new
 802 ###############################################################################
 803 sub new {
 804     my($class, $svnrep, $project) = @_;
 805
 806     if (!defined $svnrep) {
 807         croak "Must specify Subversion repository URL";
 808     }
 809
 810     $project = '' if ! defined $project;
 811
 812     my $self = bless
 813         {
 814             repository           => $svnrep,
 815             project              => $project,
 816             interactive          => 0,
 817             user                 => undef,
 818             passwd               => undef,
 819             silent               => undef,
 820             verbose              => undef,
 821             paginate             => 0,
 822             svn_output           => undef,
 823             get_readonly         => 1,
 824             get_compare          => 1,
 825             get_eol_type         => 0,
 826             implicit_projects    => undef,
 827             use_tempfiles        => 0,
 828             _tempdir             => undef,
 829             _debug               => 0,
 830             _whoami              => undef,
 831         }, $class;
 832
 833     # test to ensure 'svn' command is available
 834     $self->svn("help", -2) or
 835         croak "Could not run Subversion 'svn' command: "
 836             . "ensure it is in your PATH";
 837
 838     $self->set_project($project);
 839
 840     return $self;
 841
 842 }
 843
 844 ###############################################################################
 845 #  set_project
 846 ###############################################################################
 847 sub set_project {
 848     my($self, $project) = @_;
 849
 850     $project =~ s/\/$//;
 851     $self->{project} = $project;
 852
 853 }  # End set_project
 854
 855 ###############################################################################
 856 #  do
 857 ###############################################################################
 858 sub do {
 859     my($self, $cmd, $file, $args, $silent) = @_;
 860
 861     # basically a wrapper for "svn" to set current project and repository
 862
 863     my $url = "$self->{repository}/";
 864     $url .= $self->{project}
 865         if defined $self->{project} && $self->{project} ne '';
 866
 867     $url .= $file if defined $file;
 868     $args = '' unless defined $args;
 869
 870     return $self->svn("$cmd $url $args", $silent);
 871 }
 872
 873 ###############################################################################
 874 #  svn
 875 ###############################################################################
 876 sub svn {
 877     my($self, $cmd, $silent) = @_;
 878     # "raw" svn client access.
 879
 880     # silent values:
 881     #  0: print everything
 882     #  1: print program output only
 883     #  2: print err msgs only
 884     #  3: print nothing
 885     # -n: use 'n' only if 'silent' attribute not set
 886
 887     if (defined($silent) && $silent < 0) {
 888         $silent = first {defined} $self->{silent}, $silent;
 889     } else {
 890         $silent = first {defined} $silent, $self->{silent}, 0;
 891     }
 892
 893     $silent = abs($silent);
 894
 895     $cmd =~ s/^\s*(svn)?\s*//;  #take off "svn" if present; we'll add back later
 896     $cmd =~ s/\s+$//;
 897
 898     $cmd =~ m/^(\w+)/;
 899
 900     my $disp_cmd = $cmd;
 901
 902     if (defined $gInteractiveCmds{$1} && !$self->{interactive}) {
 903         $cmd = "$cmd --non-interactive";
 904
 905         if (defined $self->{user} && $cmd !~ /--username/) {
 906             if (defined $self->{passwd} && $cmd !~ /--password/) {
 907                 $disp_cmd = "$cmd --username \"$self->{user}\" --password *****";
 908                 $cmd = "$cmd --username \"$self->{user}\" "
 909                     . "--password \"$self->{passwd}\"";
 910             } else {
 911                 $disp_cmd = $cmd = "$cmd --username \"$self->{user}\"";
 912             }
 913         }
 914
 915     }
 916
 917     $cmd = "svn $cmd";
 918
 919     my($rv, $output);
 920
 921     warn "DEBUG: $disp_cmd\n\n" if $self->{_debug};
 922
 923     open CMDOUT, '-|', "$cmd 2>&1";
 924
 925     while (<CMDOUT>) {
 926         $output .= $_;
 927     }
 928
 929     close CMDOUT;
 930     $output =~ s/\s+$// if defined $output;
 931
 932     if ($silent <= 1) {
 933         if ($self->{paginate}) {
 934             my $linecount = 1;
 935
 936             foreach my $line (split "\n", $output) {
 937                 print "$line\n";
 938
 939                 unless ($linecount++ % $self->{paginate}) {
 940                     print "Hit ENTER to continue...\r";
 941                     <STDIN>;
 942
 943                     print "                        \r";
 944
 945                 }
 946
 947             }
 948
 949         } else {
 950             print "$output\n";
 951         }
 952
 953     }
 954
 955     my $ev = $? >> 8;
 956     my $success = !$ev;
 957
 958     if (!$success && ($silent == 0 || $silent == 2)) {
 959
 960         carp "\nERROR in Vss2Svn::Subversion-\>ss\n"
 961             . "Command was: $disp_cmd\n   "
 962             . "(Error $ev) $output\n ";
 963         warn "\n";
 964
 965     }
 966
 967     $self->{svn_output} = $output;
 968     return $success;
 969
 970 }
 971
 972 ###############################################################################
 973 #  Initialize
 974 ###############################################################################
 975 sub Initialize {
 976
 977     # commands which allow --non-interactive
 978     %gInteractiveCmds = ( map {$_,1 }
 979                                 qw(blame cat checkout co commit ci copy cp delete del
 980                                 remove rm diff di export import list ls log merge
 981                                 mkdir move rename rn propdel pdel pd propedit pedit pe
 982                                 propget pget pg proplist plist pl propset pset ps
 983                                 status stat st switch sw update up))
 984 }
 985
 986
 987 ###############################################################################
 988 #                        package Vss2Svn::VSS                                 #
 989 ###############################################################################
 990
 991 package Vss2Svn::VSS;
 992
 993 require 5.005_62;
 994 use strict;
 995 use warnings;
 996
 997 use base 'Vss2Svn';
 998 use File::Path;
 999 use File::Copy;
1000 use Win32::TieRegistry (Delimiter => '/');
1001 use Time::ParseDate;
1002
1003 use Cwd;
1004 use Cwd 'chdir';
1005
1006 sub first(&@);
1007
1008 use Carp;
1009 our $VERSION = '1.05';
1010
1011 our(%gErrMatch, %gHistLineMatch, @gDevPatterns);
1012
1013 ###############################################################################
1014 #   new
1015 ###############################################################################
1016 sub new {
1017     my($class, $db, $project, $args) = @_;
1018
1019     if (!defined $db) {
1020         croak "Must specify VSS database path";
1021     }
1022
1023     $db =~ s/[\/\\]?(srcsafe.ini)?$//i;
1024
1025     if (defined $project && $project ne ''
1026         && $project ne '$' && $project !~ /^\$\//) {
1027         croak "Project path must be absolute (begin with $/)";
1028     }
1029
1030     $project = first {defined} $project, '$/';
1031     $args = first {defined} $args, {};
1032
1033     my $self = bless
1034         {
1035             database             => $db,
1036             interactive          => 0,
1037             user                 => undef,
1038             passwd               => undef,
1039             silent               => undef,
1040             verbose              => undef,
1041             paginate             => 0,
1042             last_ss_output       => undef,
1043             get_readonly         => 1,
1044             get_compare          => 1,
1045             get_eol_type         => 0,
1046             implicit_projects    => undef,
1047             use_tempfiles        => 0,
1048             timebias             => 0,
1049             _tempdir             => undef,
1050             _debug               => 0,
1051             _whoami              => undef,
1052             %$args,
1053         }, $class;
1054
1055     # test to ensure 'ss' command is available
1056     $self->ss("WHOAMI", -2) or
1057         croak "Could not run VSS 'ss' command: ensure it is in your PATH";
1058
1059     $self->{_whoami} = $self->{last_ss_output};
1060     $self->{_whoami} =~ s/\s*$//;
1061     $self->{_whoami} =~ s/^.*\n//;
1062
1063     if ($self->{last_ss_output} =~ /changing project/im ||
1064          !$self->_check_ss_inifile) {
1065         croak "FATAL ERROR: You must not set the Force_Dir or Force_Prj VSS\n"
1066             . "variables when running SourceSync. These variables can be\n"
1067             . "cleared by unchecking the two \"Assume...\" boxes in SourceSafe\n"
1068             . "Explorer under Tools -> Options -> Command Line Options.\n ";
1069     }
1070
1071     if ($project eq '') {
1072         $self->ss('PROJECT', -2);
1073
1074         $project = $self->{last_ss_output};
1075         $project =~ s/^Current project is *//i;
1076         $project .= '/' unless $project =~ m/\/$/;
1077
1078         $self->{project} = $project;
1079     } else {
1080         $self->set_project($project);
1081     }
1082
1083     return $self;
1084
1085 }  #End new
1086
1087 ###############################################################################
1088 #  _check_ss_inifile
1089 ###############################################################################
1090 sub _check_ss_inifile {
1091     my($self) = @_;
1092
1093     my $user = lc($self->{_whoami});
1094     my $path = "$self->{database}/users/$user/ss.ini";
1095
1096     open SSINI, $path or croak "Could not open user init file $path";
1097     my $success = 1;
1098
1099 LINE:
1100     while (<SSINI>) {
1101         if (m/Force_/i) {
1102             $success = 0;
1103             last LINE;
1104         }
1105     }
1106
1107     close SSINI;
1108     return $success;
1109
1110 }  # End _check_ss_inifile
1111
1112 ###############################################################################
1113 #  set_project
1114 ###############################################################################
1115 sub set_project {
1116     my($self, $project) = @_;
1117
1118     $project .= '/' unless $project =~ m/\/$/;
1119
1120     $self->ss("CP \"$project\"", -2) or
1121         croak "Could not set current project to $project:\n"
1122             . "  $self->{last_ss_output}\n ";
1123
1124     $self->{project} = $project;
1125
1126 }  # End set_project
1127
1128 ###############################################################################
1129 #  project_tree
1130 ###############################################################################
1131 sub project_tree {
1132     my($self, $project, $recursive, $remove_dev) = @_;
1133
1134     # returns a nested-hash "tree" of all subprojects and files below the given
1135     # project; the "leaves" of regular files are the value "1".
1136
1137     $project = $self->full_path($project);
1138     $recursive = 1 unless defined $recursive;
1139     $remove_dev = 0 unless defined $remove_dev;
1140
1141     if ($self->filetype($project) ) { # projects are type 0
1142         carp "project_tree(): '$project' is not a valid project";
1143         return undef;
1144     }
1145
1146     my $cmd = "DIR \"$project\"";
1147     $cmd .= ($recursive)? ' -R' : ' -R-';
1148
1149     $self->ss($cmd, -2) or return undef;
1150
1151     # It would be nice if Microsoft made it easy for scripts to pick useful
1152     # information out of the project 'DIR' listings, but unfortunately that's
1153     # not the case. It appears that project listings always follow blank
1154     # lines, and begin with the full project path with a colon appended.
1155     # Within a listing, subprojects come first and begin with a dollar sign,
1156     # then files are listed alphabetically. If there are no items in a project,
1157     # it prints out a message saying so. And at the end of it all, you get
1158     # a statement like "7 item(s)".
1159
1160     my %tree = ();
1161     my $branch_ref = \%tree;
1162
1163     my $seen_blank_line = 0;
1164     my($current_project);
1165     my $match_project = quotemeta($project);
1166
1167 LINE:
1168     foreach my $line (split "\n", $self->{last_ss_output}) {
1169         $line =~ s/\s+$//;
1170
1171         if ($line eq '') {
1172             if ($seen_blank_line) {
1173                 carp "project_tree(): an internal error has occured -- 1";
1174                 return undef;
1175             }
1176
1177             $seen_blank_line = 1;
1178             next LINE;
1179         }
1180
1181         $seen_blank_line = 0;
1182
1183         if ($line =~ m/^\d+\s+item\(s\)$/i) {
1184             # this is a count of # of items found; ignore
1185             next LINE;
1186
1187         } elsif ($line =~ m/^No items found under/i) {
1188             # extraneous info
1189             next LINE;
1190
1191         } elsif ($line =~ m/^(\$\/.*):$/) {
1192             # this is the beginning of a project's listing
1193             $current_project = $1;
1194             # make current project relative to initial
1195             $current_project =~ s/^$match_project\/?//i;
1196             $current_project =~ s/^\$\///; # take off initial $/ if still there
1197
1198             $branch_ref = \%tree;
1199
1200             if ($current_project ne '') {
1201                 # get a reference to the end branch of subprojects
1202                 ($branch_ref) = reverse(map {$branch_ref = $branch_ref->{$_}}
1203                                                 split('/', $current_project));
1204             }
1205
1206             if (!defined $branch_ref) {
1207                 carp "project_tree(): an internal error has occured -- 2";
1208                 return undef;
1209             }
1210
1211             next LINE;
1212         } elsif ($line =~ m/^\$(.*)/) {
1213             # this is a subproject; create empty hash if not already there
1214             if (!defined $current_project) {
1215                 carp "project_tree(): an internal error has occured -- 3";
1216                 return undef;
1217             }
1218
1219             $branch_ref->{$1} = {} unless defined($branch_ref->{$1});
1220         } else {
1221             # just a regular file
1222             if (!defined $current_project) {
1223                 carp "project_tree(): an internal error has occured -- 4";
1224                 return undef;
1225             }
1226
1227             if ($remove_dev) {
1228                 foreach my $pattern (@gDevPatterns) {
1229                     next LINE if $line =~ m/$pattern/;
1230                 }
1231             }
1232
1233             $branch_ref->{$line} = 1;
1234         }
1235
1236     }
1237
1238     return \%tree;
1239
1240 }  # End project_tree
1241
1242 ###############################################################################
1243 #  file_history
1244 ###############################################################################
1245 sub file_history {
1246     my($self, $file) = @_;
1247     # returns an array ref of hash refs from earliest to most recent;
1248     # each hash has the following items:
1249     #    version: version (revision) number
1250     #    user   : name of user who committed change
1251     #    date   : date in YYYYMMDD format
1252     #    time   : time in HH:MM (24h) format
1253     #    comment: checkin comment
1254
1255     $file = $self->full_path($file);
1256
1257     if ($self->filetype($file) < 1) { # regular files are type 1 or 2
1258         carp "file_history(): '$file' is not a valid regular file";
1259         return undef;
1260     }
1261
1262     my $cmd = "HISTORY \"$file\"";
1263     my $tmpfile = '';
1264
1265     $self->ss($cmd, -2) or return undef;
1266
1267     my $hist = [];
1268
1269     my $last = 0; # what type was the last line read?
1270                       # 0=start;1=version line;2=user/date/time;3="Checked In";
1271                       # 4=comment
1272
1273     my $last_version = -1;
1274
1275     my$rev = {}; # hash of info for the lastent revision
1276     my($year,$month,$day,$hour,$min,$ampm,$comment,$version);
1277
1278 HISTLINE:
1279     foreach my $line (split "\n", $self->{last_ss_output}) {
1280         if ($self->{_debug}) {
1281             warn "\nDEBUG:($last)<$line>\n";
1282         }
1283
1284         if ($last == 0) {
1285             if ($line =~ m/$gHistLineMatch{version}/) {
1286
1287                 if ($last_version == 0 ||
1288                      (($last_version != -1) && ($1 != ($last_version - 1)))) {
1289
1290                     # each version should be one less than the last
1291                     print "file_history(): internal consistency failure";
1292                     return undef;
1293                 }
1294
1295                 $last = 1;
1296                 $rev->{version} = $1;
1297             }
1298
1299             next HISTLINE;
1300         } # if $last == 0
1301
1302         if ($last == 1) {
1303             if ($line =~ m/$gHistLineMatch{userdttm}/) {
1304                 $last = 2;
1305                 $comment = '';
1306
1307                 if ($gCfg{dateFormat} == 1) {
1308                     # DD-MM-YY
1309                     ($rev->{user}, $day, $month, $year, $hour, $min, $ampm)
1310                         = ($1, $2, $3, $4, $5, $6, $7);
1311                 } elsif ($gCfg{dateFormat} == 2) {
1312                     # YY-MM-DD
1313                     ($rev->{user}, $year, $month, $day, $hour, $min, $ampm)
1314                         = ($1, $2, $3, $4, $5, $6, $7);
1315                 } else {
1316                     # MM-DD-YY
1317                     ($rev->{user}, $month, $day, $year, $hour, $min, $ampm)
1318                         = ($1, $2, $3, $4, $5, $6, $7);
1319                 }
1320
1321                 $year = ($year > 79)? "19$year" : "20$year";
1322                 $hour += 12 if $ampm =~ /p/i;
1323
1324                 if ($self->{timebias} != 0) {
1325                     my $basis = parsedate("$year/$month/$day $hour:$min");
1326                     (my $bias = $gCfg{timebias}) =~ s/^(\d+)/+ $1/;
1327                     my $epoch_secs = parsedate("$bias minutes",
1328                                                NOW => $basis);
1329
1330                     (undef,$min,$hour,$day,$month,$year)
1331                         = localtime($epoch_secs);
1332
1333                     $month += 1;
1334                     $year += 1900; #no, not a Y2K bug; $year = 100 in 2000
1335                 }
1336
1337                 $rev->{date} = sprintf("%4.4i-%2.2i-%2.2i",
1338                                        $year, $month, $day);
1339                 $rev->{time} = sprintf("%2.2i:%2.2i", $hour, $min);
1340             } elsif ($line =~ m/$gHistLineMatch{label}/) {
1341                 # this is an inherited Label; ignore it
1342
1343             } else {
1344                 # user, date, and time should always come after header line
1345                 print "file_history(): internal consistency failure";
1346                 return undef;
1347             }
1348
1349             next HISTLINE;
1350         } # if $last == 1
1351
1352         if ($last == 2) {
1353             if ($line =~ s/$gHistLineMatch{comment}//) {
1354                 $last = 4;
1355                 $comment = $line;
1356             }
1357
1358             next HISTLINE;
1359         }
1360
1361         if ($last == 4) {
1362             if ($line =~ m/$gHistLineMatch{version}/) {
1363                 $last = 1;
1364                 $version = $1;
1365
1366                 $comment =~ s/\s+$//;
1367                 $comment =~ s/^\s+//;
1368                 $rev->{comment} = $comment;
1369
1370                 unshift @$hist, $rev;
1371
1372                 $rev = {};
1373                 $rev->{version} = $version;
1374             } else {
1375                 $comment .= "\n$line";
1376             }
1377
1378         next HISTLINE;
1379         }
1380     }
1381
1382     if ($last == 4) {
1383         $comment =~ s/\n/ /g;
1384         $comment =~ s/\s+$//;
1385         $comment =~ s/^\s+//;
1386         $rev->{comment} = $comment;
1387     } else {
1388         # last line of history should always be part of a comment, but
1389         # sometimes VSS doesn't include the final comment line
1390         $rev->{comment} = '(no comment)';
1391     }
1392
1393     unshift @$hist, $rev;
1394     return $hist;
1395 }
1396
1397 ###############################################################################
1398 #  filetype
1399 ###############################################################################
1400 sub filetype {
1401     # -1: error
1402     #  0: project
1403     #  1: text
1404     #  2: binary
1405
1406     my($self, $file) = @_;
1407     return -1 unless defined $file;
1408
1409     #$file =~ s/\s//g;
1410
1411     # special cases
1412     return 0 if $file eq '$/';
1413     return -1 if $file eq '$';
1414
1415     # VSS has no decent way of determining whether an item is a project of
1416     # a file, so we do this in a somewhat roundabout way
1417
1418     $file =~ s/[\/\\]$//;
1419
1420     my $bare = $file;
1421     $bare =~ s/.*[\/\\]//;
1422     $bare = quotemeta($bare);
1423
1424     $self->ss("PROPERTIES \"$file\" -R-", -3) or return -1;
1425
1426     my $match_isproject = "^Project:.*$bare\\s*\$";
1427     my $match_notfound = "$bare\\s*is not an existing filename or project";
1428
1429     if ($self->{last_ss_output} =~ m/$match_isproject/mi) {
1430         return 0;
1431     } elsif ($self->{last_ss_output} =~ m/$match_notfound/mi) {
1432         return -1;
1433      } else {
1434         $self->ss("FILETYPE \"$file\"", -3) or return -1;
1435
1436         if ($self->{last_ss_output} =~ m/^$bare\s*Text/mi) {
1437             return 1;
1438         } else {
1439             return 2;
1440         }
1441
1442     }
1443
1444 }  # End filetype
1445
1446 ###############################################################################
1447 #  full_path
1448 ###############################################################################
1449 sub full_path {
1450     # returns the full VSS path to a given project file.
1451
1452     my($self, $file) = @_;
1453
1454     $file =~ s/^\s+//;
1455     $file =~ s/\s+$//;
1456     $file =~ s/\/$// unless $file eq '$/';
1457
1458     return $file if $self->{implicit_projects};
1459
1460     $file = "$self->{project}$file" unless $file =~ m/^\$/;
1461     $file =~ s/\/$// unless $file eq '$/'; # in case empty string was passed
1462
1463     return $file;
1464 }  # End full_path
1465
1466 ###############################################################################
1467 #  ss
1468 ###############################################################################
1469 sub ss {
1470     my($self, $cmd, $silent) = @_;
1471
1472     # SS command-line tool access.
1473
1474     # silent values:
1475     #  0: print everything
1476     #  1: print program output only
1477     #  2: print err msgs only
1478     #  3: print nothing
1479     # -n: use 'n' only if 'silent' attribute not set
1480
1481     if (defined($silent) && $silent < 0) {
1482         $silent = first {defined} $self->{silent}, $silent;
1483     } else {
1484         $silent = first {defined} $silent, $self->{silent}, 0;
1485     }
1486
1487     $silent = abs($silent);
1488
1489     $cmd =~ s/^\s+//;
1490     $cmd =~ s/\s+$//;
1491
1492     (my $cmd_word = lc($cmd)) =~ s/^(ss(\.exe)?\s+)?(\S+).*/$3/i;
1493
1494     $cmd = "ss $cmd" unless ($cmd =~ m/^ss(\.exe)?\s/i);
1495
1496     if ($self->{interactive} =~ m/^y/i) {
1497         $cmd = "$cmd -I-Y";
1498     } elsif ($self->{interactive} =~ m/^n/i) {
1499         $cmd = "$cmd -I-N";
1500     } elsif (!$self->{interactive}) {
1501         $cmd = "$cmd -I-"
1502     }
1503
1504     my $disp_cmd = $cmd;
1505
1506     if (defined $self->{user} && $cmd !~ /\s-Y/i) {
1507         if (defined $self->{passwd}) {
1508             $disp_cmd = "$cmd -Y$self->{user},******";
1509             $cmd = "$cmd -Y$self->{user},$self->{passwd}";
1510         } else {
1511             $disp_cmd = $cmd = "$cmd -Y$self->{user}";
1512         }
1513     }
1514
1515     my($rv, $output);
1516
1517     warn "DEBUG: $disp_cmd\n\n" if $self->{_debug};
1518
1519     $ENV{SSDIR} = $self->{database};
1520
1521     if ($self->{use_tempfiles} &&
1522         $cmd_word =~ /^(dir|filetype|history|properties)$/) {
1523         my $tmpfile = "$self->{use_tempfiles}/${cmd_word}_cmd.txt";
1524         unlink $tmpfile;
1525         $cmd = "$cmd \"-O\&$tmpfile\"";
1526         system $cmd;
1527
1528         if (open SS_OUTPUT, "$tmpfile") {
1529             local $/;
1530             $output = scalar <SS_OUTPUT>;
1531             close SS_OUTPUT;
1532             unlink $tmpfile;
1533         } else {
1534             warn "Can't open '$cmd_word' tempfile $tmpfile";
1535             undef $output;
1536         }
1537
1538     } else {
1539         open SS_OUTPUT, '-|', "$cmd 2>&1";
1540
1541         while (<SS_OUTPUT>) {
1542             $output .= $_;
1543         }
1544
1545         close SS_OUTPUT;
1546         $output =~ s/\s+$// if defined $output;
1547     }
1548
1549     if ($silent <= 1) {
1550         if ($self->{paginate}) {
1551             my $linecount = 1;
1552
1553             foreach my $line (split "\n", $output) {
1554                 print "$line\n";
1555
1556                 unless ($linecount++ % $self->{paginate}) {
1557                     print "Hit ENTER to continue...\r";
1558                     <STDIN>;
1559
1560                     print "                        \r";
1561
1562                 }
1563
1564             }
1565
1566         } else {
1567             print "$output\n";
1568         }
1569
1570     }
1571
1572     my $ev = $? >> 8;
1573
1574     # SourceSafe returns 1 to indicate warnings, such as no results returned
1575     # from a 'DIR'. We don't want to consider these an error.
1576     my $success = !($ev > 1);
1577
1578     if ($success) {
1579         # This is interesting. If a command only partially fails (such as GET-ing
1580         # multiple files), that's apparently considered a success. So we have to
1581         # try to fix that.
1582         my $base_cmd = uc($cmd);
1583         $base_cmd =~ s/^(ss\s*)?(\w+).*/$2/i;
1584
1585         my $err_match;
1586
1587         if (defined($err_match = $gErrMatch{$base_cmd}) &&
1588                         $output =~ m/$err_match/m) {
1589             $success = 0;
1590         }
1591
1592     }
1593
1594     if (!$success && ($silent == 0 || $silent == 2)) {
1595
1596         carp "\nERROR in Vss2Svn::VSS-\>ss\n"
1597             . "Command was: $disp_cmd\n   "
1598             . "(Error $ev) $output\n ";
1599         warn "\n";
1600
1601     }
1602
1603     $self->{last_ss_output} = $output;
1604     return $success;
1605
1606 }  # End ss
1607
1608 ###############################################################################
1609 #  _msg
1610 ###############################################################################
1611 sub _msg {
1612     my $self = shift;
1613     print @_ unless $self->{silent};
1614 }  # End _msg
1615
1616 ###############################################################################
1617 #  _vm  -- "verbose message"
1618 ###############################################################################
1619 sub _vm {
1620     my $self = shift;
1621     print @_ if $self->{verbose};
1622 }  # End _vm
1623
1624 ###############################################################################
1625 #  Initialize
1626 ###############################################################################
1627 sub Initialize {
1628     my $dateFormat = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
1629                              . 'International/iDate'} || 0;
1630     my $dateSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
1631                              . 'International/sDate'} || '/';
1632     my $timeSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
1633                              . 'International/sTime'} || ':';
1634     $gCfg{dateFormat} = $dateFormat;
1635
1636     # see ss method for explanation of this
1637     %gErrMatch = (
1638                     GET    => 'is not an existing filename or project',
1639                     CREATE => 'Cannot change project to',
1640                     CP     => 'Cannot change project to',
1641                  );
1642
1643     %gHistLineMatch = (
1644         version    => qr/^\*+\s*Version\s+(\d+)\s*\*+\s*$/,
1645         userdttm   => qr/^User:\s+(.*?)\s+
1646                           Date:\s+(\d+)$dateSep(\d+)$dateSep(\d+)\s+
1647                           Time:\s+(\d+)$timeSep(\d+)([ap]*)\s*$/x,
1648         comment    => qr/^Comment:\s*/,
1649         label      => qr/^Label:/,
1650     );
1651
1652     # patterns to match development files that project_tree will ignore
1653 #    @gDevPatterns = (
1654 #                        qr/\.perlproj$/,
1655 #                        qr/\.vspscc$/,
1656 #                        qr/\.vssscc$/,
1657 #                        qr/\.sln$/,
1658 #                    );
1659
1660 }  # End Initialize
1661
1662 sub first(&@) {
1663         my $code = shift;
1664         &$code && return $_ for @_;
1665         return undef;
1666 }
1667
1668
1669 1;
1670
1671 __END__
1672 =pod
1673
1674 =head1 LICENSE
1675
1676 vss2svn.pl, Copyright (C) 2004 by Toby Johnson.
1677
1678 This program is free software; you can redistribute it and/or
1679 modify it under the terms of the GNU General Public License
1680 as published by the Free Software Foundation; either version 2
1681 of the License, or (at your option) any later version.
1682
1683 This program is distributed in the hope that it will be useful,
1684 but WITHOUT ANY WARRANTY; without even the implied warranty of
1685 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1686 GNU General Public License for more details.
1687 L<http://www.gnu.org/copyleft/gpl.html>
1688
1689 =head1 SYNOPSIS
1690
1691 vss2svn.pl S<--vssproject $/vss/project> S<--svnrepo http://svn/repo/url>
1692
1693 =over 4
1694
1695 =item --vssproject:
1696
1697 full path to VSS project you want to migrate
1698
1699 =item --svnrepo:
1700
1701 URL to target Subversion repository
1702
1703 =back
1704
1705 =head1 OPTIONS
1706
1707 =over 4
1708
1709 =item --comment "MESSAGE":
1710
1711 add MESSAGE to end of every migrated comment
1712
1713 =item --setdates:
1714
1715 Sets the "svn:date" property off all commits to reflect the
1716 original VSS commit date, so that the original commit dates
1717 (and not today's date) show up in your new SVN logs. This is
1718 not the default, since setting svn:date could lead to
1719 problems if not done correctly. Using this also requires the
1720 "pre-revprop-change" Hook Script to be set; see
1721 L<http://svnbook.red-bean.com/svnbook/ch05s02.html#svn-ch-5-sect-2.1>
1722
1723 =item --login "USER:PASSWD":
1724
1725 Set VSS username and password, separated by a colon.
1726 B<WARNING --> if the username/password combo you provide is
1727 incorrect, this program will hang as ss.exe prompts you for
1728 a username! (This is an unavoidable Microsoft bug).
1729
1730 =item --noprompt:
1731
1732 Don't prompt to create usernames after the first stage
1733 of the migration (see last paragraph below)
1734
1735 =back
1736
1737 B<USE --help TO VIEW FULL HELP INFORMATION>
1738
1739 =head1 DESCRIPTION
1740
1741 The URL you provide for "svnrepo" will become the base URL for all migrated
1742 files, so for the usage example above, B<$/vss/project/foo.c> would become
1743 B<http://svn/repository/url/foo.c>. Plan your migration accordingly so that you
1744 end up with the structure that you want. The URL also cannot contain any
1745 existing files; but as long as the "parent" of the URL is a Subversion
1746 repository, any non-existent directories in the URL will be created.
1747
1748 The B<$SSDIR> environment variable must be set to the directory where your
1749 system srcsafe.ini file is located; see the VSS online help for more info.
1750 The "svn" and "ss" command-line executables must also be in your PATH.
1751
1752 This script is released into the public domain. In case you're wondering
1753 about why the Vss2Svn packages have unused methods, it's because they came
1754 from in-house modules which had more functionality than just this conversion.
1755
1756 I recommend converting only a small branch at first to see how things go.
1757 This process takes a very long time for large databases. I have made liberal
1758
1759 Partway through the migration, you will be presented with a list of all
1760 usernames which performed any checkin operations in the given VSS project.
1761 If you want these user names to be preserved, you must add this list
1762 (including a user "vss_migration" for creating directories and such) to your
1763 Apache AuthUserFile with *blank passwords*. Apache must also *require* that
1764 usernames be passed, otherwise SVN will use anonymous access and you lose
1765 the usernames. So you need an "AuthType Basic" line or the like, as well as
1766 an AuthUserFile. See L<http://svnbook.red-bean.com/svnbook/ch06s04.html#svn-ch-6-sect-4.3>
1767 for more info.