legacy/lib/Vss2Svn/VSS.pm

   1 ###############################################################################
   2 #                        package Vss2Svn::VSS                                 #
   3 ###############################################################################
   4
   5 package Vss2Svn::VSS;
   6
   7 require 5.005_62;
   8 use strict;
   9 use warnings;
  10
  11 use base 'Vss2Svn';
  12 use File::Path;
  13 use File::Copy;
  14 use Win32::TieRegistry (Delimiter => '/');
  15 use Time::ParseDate;
  16
  17 use Cwd;
  18 use Cwd 'chdir';
  19
  20 sub first(&@);
  21
  22 use Carp;
  23 our $VERSION = '1.05';
  24
  25 our(%gCfg, %gErrMatch, %gHistLineMatch, @gDevPatterns);
  26
  27 ###############################################################################
  28 #   new
  29 ###############################################################################
  30 sub new {
  31     my($class, $db, $project, $args) = @_;
  32
  33     if (!defined $db) {
  34         croak "Must specify VSS database path";
  35     }
  36
  37     $db =~ s/[\/\\]?(srcsafe.ini)?$//i;
  38
  39     if (defined $project && $project ne ''
  40         && $project ne '$' && $project !~ /^\$\//) {
  41         croak "Project path must be absolute (begin with $/)";
  42     }
  43
  44     $project = first {defined} $project, '$/';
  45     $args = first {defined} $args, {};
  46
  47     my $self = bless
  48         {
  49             database             => $db,
  50             interactive          => 0,
  51             user                 => undef,
  52             passwd               => undef,
  53             silent               => undef,
  54             verbose              => undef,
  55             paginate             => 0,
  56             ss_output            => undef,
  57             ss_error             => undef,
  58             get_readonly         => 1,
  59             get_compare          => 1,
  60             get_eol_type         => 0,
  61             implicit_projects    => undef,
  62             use_tempfiles        => 0,
  63             timebias             => 0,
  64             _tempdir             => undef,
  65             _debug               => 0,
  66             _whoami              => undef,
  67             %$args,
  68         }, $class;
  69
  70     # test to ensure 'ss' command is available
  71     $self->ss("WHOAMI", -2) or
  72         croak "Could not run VSS 'ss' command: ensure it is in your PATH";
  73
  74     $self->{_whoami} = $self->{ss_output};
  75     $self->{_whoami} =~ s/\s*$//;
  76     $self->{_whoami} =~ s/^.*\n//;
  77
  78     if ($self->{ss_output} =~ /changing project/im ||
  79          !$self->_check_ss_inifile) {
  80         croak "FATAL ERROR: You must not set the Force_Dir or Force_Prj VSS\n"
  81             . "variables when running SourceSync. These variables can be\n"
  82             . "cleared by unchecking the two \"Assume...\" boxes in SourceSafe\n"
  83             . "Explorer under Tools -> Options -> Command Line Options.\n ";
  84     }
  85
  86     if ($project eq '') {
  87         $self->ss('PROJECT', -2);
  88
  89         $project = $self->{ss_output};
  90         $project =~ s/^Current project is *//i;
  91         $project .= '/' unless $project =~ m/\/$/;
  92
  93         $self->{project} = $project;
  94     } else {
  95         $self->set_project($project);
  96     }
  97
  98     return $self;
  99
 100 }  #End new
 101
 102 ###############################################################################
 103 #  _check_ss_inifile
 104 ###############################################################################
 105 sub _check_ss_inifile {
 106     my($self) = @_;
 107
 108     my $user = lc($self->{_whoami});
 109     my $path = "$self->{database}/users/$user/ss.ini";
 110
 111     open SSINI, $path or croak "Could not open user init file $path";
 112     my $success = 1;
 113
 114 LINE:
 115     while (<SSINI>) {
 116         if (m/Force_/i) {
 117             $success = 0;
 118             last LINE;
 119         }
 120     }
 121
 122     close SSINI;
 123     return $success;
 124
 125 }  # End _check_ss_inifile
 126
 127 ###############################################################################
 128 #  set_project
 129 ###############################################################################
 130 sub set_project {
 131     my($self, $project) = @_;
 132
 133     $project .= '/' unless $project =~ m/\/$/;
 134
 135     $self->ss("CP \"$project\"", -2) or
 136         croak "Could not set current project to $project:\n"
 137             . "  $self->{ss_output}\n ";
 138
 139     $self->{project} = $project;
 140
 141 }  # End set_project
 142
 143 ###############################################################################
 144 #  project_tree
 145 ###############################################################################
 146 sub project_tree {
 147     my($self, $project, $recursive, $remove_dev) = @_;
 148
 149     # returns a nested-hash "tree" of all subprojects and files below the given
 150     # project; the "leaves" of regular files are the value "1".
 151
 152     $project = $self->full_path($project);
 153     $recursive = 1 unless defined $recursive;
 154     $remove_dev = 0 unless defined $remove_dev;
 155
 156     if ($self->filetype($project) ) { # projects are type 0
 157         carp "project_tree(): '$project' is not a valid project";
 158         return undef;
 159     }
 160
 161     my $cmd = "DIR \"$project\"";
 162     $cmd .= ($recursive)? ' -R' : ' -R-';
 163
 164     $self->ss($cmd, -2) or return undef;
 165
 166     # It would be nice if Microsoft made it easy for scripts to pick useful
 167     # information out of the project 'DIR' listings, but unfortunately that's
 168     # not the case. It appears that project listings always follow blank
 169     # lines, and begin with the full project path with a colon appended.
 170     # Within a listing, subprojects come first and begin with a dollar sign,
 171     # then files are listed alphabetically. If there are no items in a project,
 172     # it prints out a message saying so. And at the end of it all, you get
 173     # a statement like "7 item(s)".
 174
 175     my %tree = ();
 176     my $branch_ref = \%tree;
 177
 178     my $seen_blank_line = 0;
 179     my($current_project);
 180     my $match_project = quotemeta($project);
 181
 182 LINE:
 183     foreach my $line (split "\n", $self->{ss_output}) {
 184         $line =~ s/\s+$//;
 185
 186         if ($line eq '') {
 187             if ($seen_blank_line) {
 188                 carp "project_tree(): an internal error has occured -- 1";
 189                 return undef;
 190             }
 191
 192             $seen_blank_line = 1;
 193             next LINE;
 194         }
 195
 196         $seen_blank_line = 0;
 197
 198         if ($line =~ m/^\d+\s+item\(s\)$/i) {
 199             # this is a count of # of items found; ignore
 200             next LINE;
 201
 202         } elsif ($line =~ m/^No items found under/i) {
 203             # extraneous info
 204             next LINE;
 205
 206         } elsif ($line =~ m/^(\$\/.*):$/) {
 207             # this is the beginning of a project's listing
 208             $current_project = $1;
 209             # make current project relative to initial
 210             $current_project =~ s/^$match_project\/?//i;
 211             $current_project =~ s/^\$\///; # take off initial $/ if still there
 212
 213             $branch_ref = \%tree;
 214
 215             if ($current_project ne '') {
 216                 # get a reference to the end branch of subprojects
 217                 ($branch_ref) = reverse(map {$branch_ref = $branch_ref->{$_}}
 218                                                 split('/', $current_project));
 219             }
 220
 221             if (!defined $branch_ref) {
 222                 carp "project_tree(): an internal error has occured -- 2";
 223                 return undef;
 224             }
 225
 226             next LINE;
 227         } elsif ($line =~ m/^\$(.*)/) {
 228             # this is a subproject; create empty hash if not already there
 229             if (!defined $current_project) {
 230                 carp "project_tree(): an internal error has occured -- 3";
 231                 return undef;
 232             }
 233
 234             $branch_ref->{$1} = {} unless defined($branch_ref->{$1});
 235         } else {
 236             # just a regular file
 237             if (!defined $current_project) {
 238                 carp "project_tree(): an internal error has occured -- 4";
 239                 return undef;
 240             }
 241
 242             if ($remove_dev) {
 243                 foreach my $pattern (@gDevPatterns) {
 244                     next LINE if $line =~ m/$pattern/i;
 245                 }
 246             }
 247
 248             $branch_ref->{$line} = 1;
 249         }
 250
 251     }
 252
 253     return \%tree;
 254
 255 }  # End project_tree
 256
 257 ###############################################################################
 258 #  file_history
 259 ###############################################################################
 260 sub file_history {
 261     my($self, $file) = @_;
 262     # returns an array ref of hash refs from earliest to most recent;
 263     # each hash has the following items:
 264     #    version: version (revision) number
 265     #    user   : name of user who committed change
 266     #    date   : date in YYYYMMDD format
 267     #    time   : time in HH:MM (24h) format
 268     #    comment: checkin comment
 269
 270     $file = $self->full_path($file);
 271
 272     my $cmd = "HISTORY \"$file\"";
 273     my $tmpfile = '';
 274
 275     $self->ss($cmd, -2) or return undef;
 276
 277     my $hist = [];
 278
 279     my $last = 0; # what type was the last line read?
 280                       # 0=start;1=version line;2=user/date/time;3="Checked In";
 281                       # 4=comment
 282
 283     my $last_version = -1;
 284
 285     my$rev = {}; # hash of info for the lastent revision
 286     my($year,$month,$day,$hour,$min,$ampm,$comment,$version);
 287
 288 HISTLINE:
 289     foreach my $line (split "\n", $self->{ss_output}) {
 290         if ($self->{_debug}) {
 291             warn "\nDEBUG:($last)<$line>\n";
 292         }
 293
 294         if ($last == 0) {
 295             if ($line =~ m/$gHistLineMatch{version}/) {
 296
 297                 if ($last_version == 0 ||
 298                      (($last_version != -1) && ($1 != ($last_version - 1)))) {
 299
 300                     # each version should be one less than the last
 301                     print "file_history(): internal consistency failure";
 302                     return undef;
 303                 }
 304
 305                 $last = 1;
 306                 $rev->{version} = $1;
 307             }
 308
 309             next HISTLINE;
 310         } # if $last == 0
 311
 312         if ($last == 1) {
 313             if ($line =~ m/$gHistLineMatch{userdttm}/) {
 314                 $last = 2;
 315                 $comment = '';
 316
 317                 if ($gCfg{dateFormat} == 1) {
 318                     # DD-MM-YY
 319                     ($rev->{user}, $day, $month, $year, $hour, $min, $ampm)
 320                         = ($1, $2, $3, $4, $5, $6, $7);
 321                 } elsif ($gCfg{dateFormat} == 2) {
 322                     # YY-MM-DD
 323                     ($rev->{user}, $year, $month, $day, $hour, $min, $ampm)
 324                         = ($1, $2, $3, $4, $5, $6, $7);
 325                 } else {
 326                     # MM-DD-YY
 327                     ($rev->{user}, $month, $day, $year, $hour, $min, $ampm)
 328                         = ($1, $2, $3, $4, $5, $6, $7);
 329                 }
 330
 331                 $year = ($year > 79)? "19$year" : "20$year";
 332
 333                 if ($ampm =~ /p/i && $hour < 12) {
 334                     $hour += 12;
 335                 } elsif ($ampm =~ /a/i && $hour == 12) {
 336                     $hour = 0;
 337                 }
 338
 339                 if ($self->{timebias} != 0) {
 340                     my $basis = parsedate("$year/$month/$day $hour:$min");
 341                     (my $bias = $self->{timebias}) =~ s/^(\d+)/+ $1/;
 342                     my $epoch_secs = parsedate("$bias minutes",
 343                                                NOW => $basis);
 344
 345                     (undef,$min,$hour,$day,$month,$year)
 346                         = localtime($epoch_secs);
 347
 348                     $month += 1;
 349                     $year += 1900; #no, not a Y2K bug; $year = 100 in 2000
 350                 }
 351
 352                 $rev->{date} = sprintf("%4.4i-%2.2i-%2.2i",
 353                                        $year, $month, $day);
 354                 $rev->{time} = sprintf("%2.2i:%2.2i", $hour, $min);
 355             } elsif ($line =~ m/$gHistLineMatch{label}/) {
 356                 # this is an inherited Label; ignore it
 357
 358             } else {
 359                 # user, date, and time should always come after header line
 360                 print "file_history(): internal consistency failure";
 361                 return undef;
 362             }
 363
 364             next HISTLINE;
 365         } # if $last == 1
 366
 367         if ($last == 2) {
 368             if ($line =~ s/$gHistLineMatch{comment}//) {
 369                 $last = 4;
 370                 $comment = $line;
 371             }
 372
 373             next HISTLINE;
 374         }
 375
 376         if ($last == 4) {
 377             if ($line =~ m/$gHistLineMatch{version}/) {
 378                 $last = 1;
 379                 $version = $1;
 380
 381                 $comment =~ s/\s+$//;
 382                 $comment =~ s/^\s+//;
 383                 $rev->{comment} = $comment;
 384
 385                 unshift @$hist, $rev;
 386
 387                 $rev = {};
 388                 $rev->{version} = $version;
 389             } else {
 390                 $comment .= "\n$line";
 391             }
 392
 393         next HISTLINE;
 394         }
 395     }
 396
 397     if ($last == 4) {
 398         $comment =~ s/\n/ /g;
 399         $comment =~ s/\s+$//;
 400         $comment =~ s/^\s+//;
 401         $rev->{comment} = $comment;
 402     } else {
 403         # last line of history should always be part of a comment, but
 404         # sometimes VSS doesn't include the final comment line
 405         $rev->{comment} = '(no comment)';
 406     }
 407
 408     unshift @$hist, $rev;
 409     return $hist;
 410 }
 411
 412 ###############################################################################
 413 #  filetype
 414 ###############################################################################
 415 sub filetype {
 416     # -1: error
 417     #  0: project
 418     #  1: text
 419     #  2: binary
 420
 421     my($self, $file) = @_;
 422     return -1 unless defined $file;
 423
 424     #$file =~ s/\s//g;
 425
 426     # special cases
 427     return 0 if $file eq '$/';
 428     return -1 if $file eq '$';
 429
 430     # VSS has no decent way of determining whether an item is a project or
 431     # a file, so we do this in a somewhat roundabout way
 432
 433     $file =~ s/[\/\\]$//;
 434
 435     my $bare = $file;
 436     $bare =~ s/.*[\/\\]//;
 437     $bare = quotemeta($bare);
 438
 439     $self->ss("PROPERTIES \"$file\" -R-", -3) or return -1;
 440
 441     my $match_isproject = "^Project:.*$bare\\s*\$";
 442     my $match_notfound = "$bare\\s*is not an existing filename or project";
 443
 444     if ($self->{ss_output} =~ m/$match_isproject/mi) {
 445         return 0;
 446     } elsif ($self->{ss_output} =~ m/$match_notfound/mi) {
 447         return -1;
 448      } else {
 449         $self->ss("FILETYPE \"$file\"", -3) or return -1;
 450
 451         if ($self->{ss_output} =~ m/^$bare\s*Text/mi) {
 452             return 1;
 453         } else {
 454             return 2;
 455         }
 456
 457     }
 458
 459 }  # End filetype
 460
 461 ###############################################################################
 462 #  full_path
 463 ###############################################################################
 464 sub full_path {
 465     # returns the full VSS path to a given project file.
 466
 467     my($self, $file) = @_;
 468
 469     $file =~ s/^\s+//;
 470     $file =~ s/\s+$//;
 471     $file =~ s/\/$// unless $file eq '$/';
 472
 473     return $file if $self->{implicit_projects};
 474
 475     $file = "$self->{project}$file" unless $file =~ m/^\$/;
 476     $file =~ s/\/$// unless $file eq '$/'; # in case empty string was passed
 477
 478     return $file;
 479 }  # End full_path
 480
 481 ###############################################################################
 482 #  ss
 483 ###############################################################################
 484 sub ss {
 485     my($self, $cmd, $silent) = @_;
 486
 487     # SS command-line tool access.
 488
 489     # silent values:
 490     #  0: print everything
 491     #  1: print program output only
 492     #  2: print err msgs only
 493     #  3: print nothing
 494     # -n: use 'n' only if 'silent' attribute not set
 495
 496     if (defined($silent) && $silent < 0) {
 497         $silent = first {defined} $self->{silent}, $silent;
 498     } else {
 499         $silent = first {defined} $silent, $self->{silent}, 0;
 500     }
 501
 502     $silent = abs($silent);
 503
 504     $cmd =~ s/^\s+//;
 505     $cmd =~ s/\s+$//;
 506
 507     (my $cmd_word = lc($cmd)) =~ s/^(ss(\.exe)?\s+)?(\S+).*/$3/i;
 508
 509     $cmd = "ss $cmd" unless ($cmd =~ m/^ss(\.exe)?\s/i);
 510
 511     if ($self->{interactive} =~ m/^y/i) {
 512         $cmd = "$cmd -I-Y";
 513     } elsif ($self->{interactive} =~ m/^n/i) {
 514         $cmd = "$cmd -I-N";
 515     } elsif (!$self->{interactive}) {
 516         $cmd = "$cmd -I-"
 517     }
 518
 519     my $disp_cmd = $cmd;
 520
 521     if (defined $self->{user} && $cmd !~ /\s-Y/i) {
 522         if (defined $self->{passwd}) {
 523             $disp_cmd = "$cmd -Y$self->{user},******";
 524             $cmd = "$cmd -Y$self->{user},$self->{passwd}";
 525         } else {
 526             $disp_cmd = $cmd = "$cmd -Y$self->{user}";
 527         }
 528     }
 529
 530     my($rv, $output);
 531
 532     warn "DEBUG: $disp_cmd\n\n" if $self->{_debug};
 533
 534     $ENV{SSDIR} = $self->{database};
 535
 536     if ($self->{use_tempfiles} &&
 537         $cmd_word =~ /^(dir|filetype|history|properties)$/) {
 538         my $tmpfile = "$self->{use_tempfiles}/${cmd_word}_cmd.txt";
 539         unlink $tmpfile;
 540         $cmd = "$cmd \"-O\&$tmpfile\"";
 541         system $cmd;
 542
 543         if (open SS_OUTPUT, "$tmpfile") {
 544             local $/;
 545             $output = scalar <SS_OUTPUT>;
 546             close SS_OUTPUT;
 547             unlink $tmpfile;
 548         } else {
 549             warn "Can't open '$cmd_word' tempfile $tmpfile";
 550             undef $output;
 551         }
 552
 553     } else {
 554         open SS_OUTPUT, '-|', "$cmd 2>&1";
 555
 556         while (<SS_OUTPUT>) {
 557             $output .= $_;
 558         }
 559
 560         close SS_OUTPUT;
 561         $output =~ s/\s+$// if defined $output;
 562     }
 563
 564     if ($silent <= 1) {
 565         if ($self->{paginate}) {
 566             my $linecount = 1;
 567
 568             foreach my $line (split "\n", $output) {
 569                 print "$line\n";
 570
 571                 unless ($linecount++ % $self->{paginate}) {
 572                     print "Hit ENTER to continue...\r";
 573                     <STDIN>;
 574
 575                     print "                        \r";
 576
 577                 }
 578
 579             }
 580
 581         } else {
 582             print "$output\n";
 583         }
 584
 585     }
 586
 587     my $ev = $? >> 8;
 588
 589     # SourceSafe returns 1 to indicate warnings, such as no results returned
 590     # from a 'DIR'. We don't want to consider these an error.
 591     my $success = !($ev > 1);
 592
 593     if ($success) {
 594         # This is interesting. If a command only partially fails (such as GET-ing
 595         # multiple files), that's apparently considered a success. So we have to
 596         # try to fix that.
 597         my $base_cmd = uc($cmd);
 598         $base_cmd =~ s/^(ss\s*)?(\w+).*/$2/i;
 599
 600         my $err_match;
 601
 602         if (defined($err_match = $gErrMatch{$base_cmd}) &&
 603                         $output =~ m/$err_match/m) {
 604             $success = 0;
 605         }
 606
 607     }
 608
 609     if ($success) {
 610         $self->{ss_error} = undef;
 611     } else {
 612         $self->{ss_error} = "$disp_cmd\n$output";
 613     }
 614
 615     if (!$success && ($silent == 0 || $silent == 2)) {
 616
 617         carp "\nERROR in Vss2Svn::VSS-\>ss\n"
 618             . "Command was: $disp_cmd\n   "
 619             . "(Error $ev) $output\n ";
 620         warn "\n";
 621
 622     }
 623
 624     $self->{ss_output} = $output;
 625     return $success;
 626
 627 }  # End ss
 628
 629 ###############################################################################
 630 #  _msg
 631 ###############################################################################
 632 sub _msg {
 633     my $self = shift;
 634     print @_ unless $self->{silent};
 635 }  # End _msg
 636
 637 ###############################################################################
 638 #  _vm  -- "verbose message"
 639 ###############################################################################
 640 sub _vm {
 641     my $self = shift;
 642     print @_ if $self->{verbose};
 643 }  # End _vm
 644
 645 ###############################################################################
 646 #  Initialize
 647 ###############################################################################
 648 sub Initialize {
 649     my $dateFormat = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 650                              . 'International/iDate'} || 0;
 651     my $dateSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 652                              . 'International/sDate'} || '/';
 653     my $timeSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 654                              . 'International/sTime'} || ':';
 655     $gCfg{dateFormat} = $dateFormat;
 656
 657     if ($dateFormat == 1) {
 658         $gCfg{dateString} = "DD${dateSep}MM${dateSep}YY";
 659     } elsif ($dateFormat == 2) {
 660         $gCfg{dateString} = "YY${dateSep}MM${dateSep}DD";
 661     } else {
 662         $gCfg{dateString} = "MM${dateSep}DD${dateSep}YY";
 663     }
 664
 665     $gCfg{timeString} = "HH${timeSep}MM";
 666
 667     # see ss method for explanation of this
 668     %gErrMatch = (
 669                     GET    => 'is not an existing filename or project',
 670                     CREATE => 'Cannot change project to',
 671                     CP     => 'Cannot change project to',
 672                  );
 673
 674     %gHistLineMatch = (
 675         version    => qr/^\*+\s*Version\s+(\d+)\s*\*+\s*$/,
 676         userdttm   => qr/^User:\s+(.*?)\s+
 677                           Date:\s+(\d+)$dateSep(\d+)$dateSep(\d+)\s+
 678                           Time:\s+(\d+)$timeSep(\d+)([ap]*)\s*$/x,
 679         comment    => qr/^Comment:\s*/,
 680         label      => qr/^Label:/,
 681     );
 682
 683     # patterns to match development files that project_tree will ignore
 684     @gDevPatterns = (
 685                         qr/\.vspscc$/,
 686                         qr/\.vssscc$/,
 687                         qr/^vssver\.scc$/,
 688                     );
 689
 690 }  # End Initialize
 691
 692 sub first(&@) {
 693         my $code = shift;
 694         &$code && return $_ for @_;
 695         return undef;
 696 }
 697
 698 1;