vss2svn.pl

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