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