ssphys/test/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                         executable                       => "ss",
  65             _tempdir             => undef,
  66             _debug               => 0,
  67             _whoami              => undef,
  68             %$args,
  69         }, $class;
  70
  71     # test to ensure 'ss' command is available
  72     $self->ss("WHOAMI", -2) or
  73         croak "Could not run VSS 'ss' command: ensure it is in your PATH";
  74
  75     $self->{_whoami} = $self->{ss_output};
  76     $self->{_whoami} =~ s/\s*$//;
  77     $self->{_whoami} =~ s/^.*\n//;
  78
  79     if ($self->{ss_output} =~ /changing project/im ||
  80          !$self->_check_ss_inifile) {
  81         croak "FATAL ERROR: You must not set the Force_Dir or Force_Prj VSS\n"
  82             . "variables when running SourceSync. These variables can be\n"
  83             . "cleared by unchecking the two \"Assume...\" boxes in SourceSafe\n"
  84             . "Explorer under Tools -> Options -> Command Line Options.\n ";
  85     }
  86
  87     if ($project eq '') {
  88         $self->ss('PROJECT', -2);
  89
  90         $project = $self->{ss_output};
  91         $project =~ s/^Current project is *//i;
  92         $project .= '/' unless $project =~ m/\/$/;
  93
  94         $self->{project} = $project;
  95     } else {
  96         $self->set_project($project);
  97     }
  98
  99     return $self;
 100
 101 }  #End new
 102
 103 ###############################################################################
 104 #  _check_ss_inifile
 105 ###############################################################################
 106 sub _check_ss_inifile {
 107     my($self) = @_;
 108
 109     my $user = lc($self->{_whoami});
 110     my $path = "$self->{database}/users/$user/ss.ini";
 111
 112     open SSINI, $path or croak "Could not open user init file $path";
 113     my $success = 1;
 114
 115 LINE:
 116     while (<SSINI>) {
 117         if (m/Force_/i) {
 118             $success = 0;
 119             last LINE;
 120         }
 121     }
 122
 123     close SSINI;
 124     return $success;
 125
 126 }  # End _check_ss_inifile
 127
 128 ###############################################################################
 129 #  set_project
 130 ###############################################################################
 131 sub set_project {
 132     my($self, $project) = @_;
 133
 134     $project .= '/' unless $project =~ m/\/$/;
 135
 136     $self->ss("CP \"$project\"", -2) or
 137         croak "Could not set current project to $project:\n"
 138             . "  $self->{ss_output}\n ";
 139
 140     $self->{project} = $project;
 141
 142 }  # End set_project
 143
 144 ###############################################################################
 145 #  project_tree
 146 ###############################################################################
 147 sub project_tree {
 148     my($self, $project, $recursive, $remove_dev) = @_;
 149
 150     # returns a nested-hash "tree" of all subprojects and files below the given
 151     # project; the "leaves" of regular files are the value "1".
 152
 153     $project = $self->full_path($project);
 154     $recursive = 1 unless defined $recursive;
 155     $remove_dev = 0 unless defined $remove_dev;
 156
 157     if ($self->filetype($project) ) { # projects are type 0
 158         carp "project_tree(): '$project' is not a valid project";
 159         return undef;
 160     }
 161
 162     my $cmd = "DIR \"$project\"";
 163     $cmd .= ($recursive)? ' -R' : ' -R-';
 164
 165     $self->ss($cmd, -2) or return undef;
 166
 167     # It would be nice if Microsoft made it easy for scripts to pick useful
 168     # information out of the project 'DIR' listings, but unfortunately that's
 169     # not the case. It appears that project listings always follow blank
 170     # lines, and begin with the full project path with a colon appended.
 171     # Within a listing, subprojects come first and begin with a dollar sign,
 172     # then files are listed alphabetically. If there are no items in a project,
 173     # it prints out a message saying so. And at the end of it all, you get
 174     # a statement like "7 item(s)".
 175
 176     my %tree = ();
 177     my $branch_ref = \%tree;
 178
 179     my $seen_blank_line = 0;
 180     my($current_project);
 181     my $match_project = quotemeta($project);
 182
 183 LINE:
 184     foreach my $line (split "\n", $self->{ss_output}) {
 185         $line =~ s/\s+$//;
 186
 187         if ($line eq '') {
 188             if ($seen_blank_line) {
 189                 carp "project_tree(): an internal error has occured -- 1";
 190                 return undef;
 191             }
 192
 193             $seen_blank_line = 1;
 194             next LINE;
 195         }
 196
 197         $seen_blank_line = 0;
 198
 199         if ($line =~ m/^\d+\s+item\(s\)$/i) {
 200             # this is a count of # of items found; ignore
 201             next LINE;
 202
 203         } elsif ($line =~ m/^No items found under/i) {
 204             # extraneous info
 205             next LINE;
 206
 207         } elsif ($line =~ m/^(\$\/.*):$/) {
 208             # this is the beginning of a project's listing
 209             $current_project = $1;
 210             # make current project relative to initial
 211             $current_project =~ s/^$match_project\/?//i;
 212             $current_project =~ s/^\$\///; # take off initial $/ if still there
 213
 214             $branch_ref = \%tree;
 215
 216             if ($current_project ne '') {
 217                 # get a reference to the end branch of subprojects
 218                 ($branch_ref) = reverse(map {$branch_ref = $branch_ref->{$_}}
 219                                                 split('/', $current_project));
 220             }
 221
 222             if (!defined $branch_ref) {
 223                 carp "project_tree(): an internal error has occured -- 2";
 224                 return undef;
 225             }
 226
 227             next LINE;
 228         } elsif ($line =~ m/^\$(.*)/) {
 229             # this is a subproject; create empty hash if not already there
 230             if (!defined $current_project) {
 231                 carp "project_tree(): an internal error has occured -- 3";
 232                 return undef;
 233             }
 234
 235             $branch_ref->{$1} = {} unless defined($branch_ref->{$1});
 236         } else {
 237             # just a regular file
 238             if (!defined $current_project) {
 239                 carp "project_tree(): an internal error has occured -- 4";
 240                 return undef;
 241             }
 242
 243             if ($remove_dev) {
 244                 foreach my $pattern (@gDevPatterns) {
 245                     next LINE if $line =~ m/$pattern/i;
 246                 }
 247             }
 248
 249             $branch_ref->{$line} = 1;
 250         }
 251
 252     }
 253
 254     return \%tree;
 255
 256 }  # End project_tree
 257
 258 ###############################################################################
 259 #  parse_date_time_user
 260 ###############################################################################
 261 sub parse_date_time_user {
 262     my($self, $line) = @_;
 263
 264     my ($user,$date,$time,$year,$month,$day,$hour,$min,$ampm);
 265
 266     $line =~ m/$gHistLineMatch{userdttm}/;
 267     if ($gCfg{dateFormat} == 1) {
 268         # DD-MM-YY
 269         ($user, $day, $month, $year, $hour, $min, $ampm)
 270             = ($1, $2, $3, $4, $5, $6, $7);
 271     } elsif ($gCfg{dateFormat} == 2) {
 272         # YY-MM-DD
 273         ($user, $year, $month, $day, $hour, $min, $ampm)
 274             = ($1, $2, $3, $4, $5, $6, $7);
 275     } else {
 276         # MM-DD-YY
 277         ($user, $month, $day, $year, $hour, $min, $ampm)
 278             = ($1, $2, $3, $4, $5, $6, $7);
 279     }
 280
 281     $year = ($year > 79)? "19$year" : "20$year";
 282
 283     if ($ampm =~ /p/i && $hour < 12) {
 284         $hour += 12;
 285     } elsif ($ampm =~ /a/i && $hour == 12) {
 286         $hour = 0;
 287     }
 288
 289     if ($self->{timebias} != 0) {
 290         my $basis = parsedate("$year/$month/$day $hour:$min");
 291         (my $bias = $self->{timebias}) =~ s/^(\d+)/+ $1/;
 292         my $epoch_secs = parsedate("$bias minutes",
 293                                    NOW => $basis);
 294
 295         (undef,$min,$hour,$day,$month,$year)
 296             = localtime($epoch_secs);
 297
 298         $month += 1;
 299         $year += 1900; #no, not a Y2K bug; $year = 100 in 2000
 300     }
 301
 302     $date = sprintf("%4.4i-%2.2i-%2.2i",
 303                            $year, $month, $day);
 304     $time = sprintf("%2.2i:%2.2i", $hour, $min);
 305
 306     my $result =
 307         { user => $user,
 308           date => $date,
 309           time => $time,};
 310
 311    return $result;
 312 }
 313
 314 ###############################################################################
 315 #  file_history
 316 ###############################################################################
 317 sub file_history {
 318     my($self, $file, $versionNumber) = @_;
 319     # returns an array ref of hash refs from earliest to most recent;
 320     # each hash has the following items:
 321     #    version: version (revision) number
 322     #    user   : name of user who committed change
 323     #    date   : date in YYYYMMDD format
 324     #    time   : time in HH:MM (24h) format
 325     #    comment: checkin comment
 326
 327     $file = $self->full_path($file);
 328
 329     my $cmd = "HISTORY -f- -l- ";
 330     $cmd .= "-v$versionNumber~$versionNumber " if (defined $versionNumber && $versionNumber >= 0);
 331     $cmd .= "\"$file\"";
 332     my $tmpfile = '';
 333
 334     my $success = $self->ss($cmd, -2);
 335     return undef if (!$success);
 336
 337     my $hist = [];
 338     my $labels = [];
 339
 340     my $state = 0;  # what type was the last line read?
 341                     # 0=start: look for a line with stars
 342                     # 2=version line
 343                     # 3=empty star line
 344                     # 4=user/date/time
 345                     # 5=label line
 346                     # 6=action line
 347                     # 7=comment line
 348                     # 8=additional comment lines
 349                     # 9=record finished
 350     my $laststate = $state;
 351     my $initstate = 1;  # perform specific action when entering a state
 352
 353     my $last_version = -1;
 354
 355     my $rev = {}; # hash of info for the lastent revision
 356     my $comment = '';
 357
 358 HISTLINE:
 359     foreach my $line (split "\n", $self->{ss_output}) {
 360
 361         my $line_processed = 0;
 362         my $error = '';
 363
 364         while (!$line_processed) {
 365             if ($state == 0) {   # search for the start of a record (a star line)
 366                 if ($line =~ m/$gHistLineMatch{version}/) {
 367                     $state = 2;
 368                 } elsif ($line =~ m/$gHistLineMatch{stars22}/) {
 369                     $state = 3;
 370                 } else {
 371                     # drop all other lines
 372                     $line_processed = 1;
 373                 }
 374             } elsif ($state == 2) {  # version record
 375                 if ($initstate) {
 376                     if ($line =~ m/$gHistLineMatch{version}/) {
 377                         $rev->{version} = $1;
 378                         $line_processed = 1;
 379                     } else {
 380                         $error = "wrong state condition ($state): version line expected\n";
 381                     }
 382                 } elsif ($line =~ m/$gHistLineMatch{label}/) {
 383                     $state = 5;
 384                 } elsif ($line =~ m/$gHistLineMatch{userdttm}/) {
 385                     $state = 4;
 386                 } else {
 387                     $error = "internal consistency failure, label or date/user line expected";
 388                 }
 389             } elsif ($state == 3) {  # project label
 390                 if ($initstate) {
 391                     if ($line =~ m/$gHistLineMatch{stars22}/) {
 392                         $line_processed = 1;
 393                     } else {
 394                         $error = "wrong state condition ($state): star line expected\n";
 395                     }
 396                 } elsif ($line =~ m/$gHistLineMatch{label}/) {
 397                     $state = 5;
 398                 } else {
 399                     $error = "internal consistency failure, label line expected";
 400                 }
 401             } elsif ($state == 4) { # user and date line
 402                 if ($initstate) {
 403                     if ($line =~ m/$gHistLineMatch{userdttm}/) {
 404                         %$rev = (%$rev, %{$self->parse_date_time_user ($line)});
 405                         $line_processed = 1;
 406                     } else {
 407                         $error = "wrong state condition ($state): date/user line expected\n";
 408                     }
 409                 } elsif ($line =~ m/$gHistLineMatch{action}/) {
 410                     $state = 6;
 411                 } elsif ($line =~ m/$gHistLineMatch{action0}/) {
 412                     $state = 6;
 413                 } elsif ($line =~ m/$gHistLineMatch{action1}/) {
 414                     $state = 6;
 415                 } elsif ($line =~ m/$gHistLineMatch{action11}/) {
 416                     $state = 6;
 417                 } elsif ($line =~ m/$gHistLineMatch{action2}/) {
 418                     $state = 6;
 419                 } elsif ($line =~ m/$gHistLineMatch{action3}/) {
 420                     $state = 6;
 421                 } else {
 422                     $error = "internal consistency failure, action line expected";
 423                 }
 424             } elsif ($state == 5) { # label line
 425                 if ($initstate) {
 426                     if ($line =~ m/$gHistLineMatch{label}/) {
 427                         $rev->{label} = $1;
 428                         $line_processed = 1;
 429                     } else {
 430                         $error = "wrong state condition ($state): label line expected\n";
 431                     }
 432                 } elsif ($line =~ m/$gHistLineMatch{userdttm}/) {
 433                     $state = 4;
 434                 } else {
 435                     $error = "internal consistency failure, date/user line expected";
 436                 }
 437             } elsif ($state == 6) { # action line
 438                 if ($initstate) {
 439                     if ($line =~ m/$gHistLineMatch{action}/) {
 440                         $rev->{action} = $line;
 441                         $rev->{path} = $2;
 442                         $line_processed = 1;
 443                                 } elsif ($line =~ m/$gHistLineMatch{action0}/) {
 444                         $rev->{action} = $line;
 445                         $line_processed = 1;
 446                     } elsif ($line =~ m/$gHistLineMatch{action1}/) {
 447                         $rev->{path} = $1;
 448                         $rev->{action} = $2 . " " . $1; # translate to OLE string
 449                         $line_processed = 1;
 450                     } elsif ($line =~ m/$gHistLineMatch{action11}/) {   # shared
 451                         # $1 is the path the share came from
 452                         # $2 is the name of the item
 453                         $rev->{path} = $2;
 454                         $rev->{action} = "Shared \$/$1$2"; # translate to OLE string
 455                         $line_processed = 1;
 456                     } elsif ($line =~ m/$gHistLineMatch{action2}/) {
 457                         $rev->{path} = $1;
 458                         $rev->{action} = "Renamed $1 to $2";
 459                         $line_processed = 1;
 460                     } elsif ($line =~ m/$gHistLineMatch{action3}/) {
 461                         $rev->{path} = $1;
 462                         $rev->{action} = "Pinned $1 to Version $2";
 463                         $line_processed = 1;
 464                     } else {
 465                         $error = "wrong state condition ($state): action line expected\n";
 466                     }
 467                 } elsif ($line =~ m/$gHistLineMatch{comment}/) {
 468                     $state = 7;
 469                 } elsif ($line eq '') {
 470                     $state = 9;
 471                 } else {
 472                     $error = "internal consistency failure, comment or empty line expected\n";
 473                 }
 474             } elsif ($state == 7) { # comment line (begin)
 475                 if ($initstate) {
 476                     if ($line =~ m/$gHistLineMatch{comment}/) {
 477                         $comment = $2;
 478                         $line_processed = 1;
 479                     } else {
 480                         $error = "wrong state condition ($state): comment line expected\n";
 481                     }
 482                 } elsif ($line =~ m/$gHistLineMatch{stars}/) {
 483                     $state = 9;
 484                 } else {
 485                     $state = 8;
 486                 }
 487             } elsif ($state == 8) { # additional comment lines
 488                 if ($line =~ m/$gHistLineMatch{stars}/) {
 489                     $state = 9;
 490                 } else {
 491                     # accumulate all other comment lines
 492                     $comment .= "\n$line";
 493                     $line_processed = 1;
 494                 }
 495             } elsif ($state == 9) { # create the record
 496                 # clean up comment text
 497                 $comment =~ s/\s+$//;
 498                 $comment =~ s/^\s+//;
 499                 if ($comment eq '') {
 500                     $comment = '(no comment)';
 501                 }
 502
 503                 $rev->{comment} = $comment;
 504
 505                 if (exists $rev->{version} && defined $rev->{version} && $rev->{version} ne '') {
 506                     warn "DEBUG: Version record: $rev->{version}, $rev->{user}, $rev->{date}, $rev->{time}: $rev->{comment}\n";
 507
 508                     $rev->{labels} = $labels;
 509                     $labels = [];
 510
 511                     unshift @$hist, $rev;
 512                 } elsif ($rev->{label} ne '') {
 513                     warn "DEBUG: Label record: $rev->{label}: $rev->{comment}\n";
 514                     unshift @$labels, $rev;
 515                 }
 516
 517                 $rev = {};
 518                 $comment = '';
 519
 520                 # drop to state 0, start looking for the next record
 521                 $state = 0;
 522             }
 523
 524             if ($state ne $laststate) {
 525                 $initstate = 1;
 526             } else {
 527                 $initstate = 0;
 528             }
 529
 530             $laststate = $state;
 531
 532
 533             if ($error ne '') { # report an error an bail out
 534                 if ($self->{_debug}) {
 535                     warn "DEBUG:($state)<$line>\n";
 536                 }
 537                 warn "DEBUG: file_history(): $error\n";
 538                 return undef;
 539             }
 540         }
 541
 542         if ($self->{_debug}) {
 543             warn "DEBUG:($state)<$line>\n";
 544         }
 545
 546         next HISTLINE;
 547     }
 548
 549     # the last record isn't finished if we are not in the initial state
 550     if ($state > 0) {
 551         # clean up comment text
 552         $comment =~ s/\s+$//;
 553         $comment =~ s/^\s+//;
 554         if ($comment eq '') {
 555             $comment = '(no comment)';
 556         }
 557
 558         $rev->{comment} = $comment;
 559
 560         if (exists $rev->{version} && defined $rev->{version} && $rev->{version} ne '') {
 561             warn "DEBUG: Version record: $rev->{version}, $rev->{user}, $rev->{date}, $rev->{time}: $rev->{comment}\n";
 562
 563             $rev->{labels} = $labels;
 564             $labels = [];
 565
 566             unshift @$hist, $rev;
 567         } elsif ($rev->{label} ne '') {
 568             warn "DEBUG: Label record: $rev->{label}: $rev->{comment}\n";
 569             unshift @$labels, $rev;
 570         }
 571     }
 572
 573     return $hist;
 574 }
 575
 576
 577 ###############################################################################
 578 #  filetype
 579 ###############################################################################
 580 sub filetype {
 581     # -1: error
 582     #  0: project
 583     #  1: text
 584     #  2: binary
 585
 586     my($self, $file) = @_;
 587     return -1 unless defined $file;
 588
 589     #$file =~ s/\s//g;
 590
 591     # special cases
 592     return 0 if $file eq '$/';
 593     return -1 if $file eq '$';
 594
 595         # special cases with version numbers ($;10 or $/;10)
 596     if ($file =~ m/\$\;\d*/mi) {
 597                 return 0;
 598     }
 599         elsif ($file =~ m/\$\/\;\d/mi) {
 600                 return 0;
 601         }
 602
 603     # VSS has no decent way of determining whether an item is a project or
 604     # a file, so we do this in a somewhat roundabout way
 605
 606     $file =~ s/[\/\\]$//;
 607
 608     my $bare = $file;
 609     $bare =~ s/.*[\/\\]//;
 610     $bare = quotemeta($bare);
 611
 612     $self->ss("PROPERTIES \"$file\" -R-", -3) or return -1;
 613
 614     my $match_isproject = "^Project:.*$bare\\s*\$";
 615     my $match_notfound = "$bare\\s*is not an existing filename or project";
 616
 617     if ($self->{ss_output} =~ m/$match_isproject/mi) {
 618         return 0;
 619     } elsif ($self->{ss_output} =~ m/$match_notfound/mi) {
 620         return -1;
 621      } else {
 622         $self->ss("FILETYPE \"$file\"", -3) or return -1;
 623
 624         if ($self->{ss_output} =~ m/^$bare\s*Text/mi) {
 625             return 1;
 626         } else {
 627             return 2;
 628         }
 629
 630     }
 631
 632 }  # End filetype
 633
 634 ###############################################################################
 635 #  full_path
 636 ###############################################################################
 637 sub full_path {
 638     # returns the full VSS path to a given project file.
 639
 640     my($self, $file) = @_;
 641
 642     $file =~ s/^\s+//;
 643     $file =~ s/\s+$//;
 644     $file =~ s/\/$// unless $file eq '$/';
 645
 646     return $file if $self->{implicit_projects};
 647
 648     $file = "$self->{project}$file" unless $file =~ m/^\$/;
 649     $file =~ s/\/$// unless $file eq '$/'; # in case empty string was passed
 650
 651     return $file;
 652 }  # End full_path
 653
 654 ###############################################################################
 655 #  ss
 656 ###############################################################################
 657 sub ss {
 658     my($self, $cmd, $silent) = @_;
 659
 660     # SS command-line tool access.
 661
 662     # silent values:
 663     #  0: print everything
 664     #  1: print program output only
 665     #  2: print err msgs only
 666     #  3: print nothing
 667     # -n: use 'n' only if 'silent' attribute not set
 668
 669     if (defined($silent) && $silent < 0) {
 670         $silent = first {defined} $self->{silent}, $silent;
 671     } else {
 672         $silent = first {defined} $silent, $self->{silent}, 0;
 673     }
 674
 675     $silent = abs($silent);
 676
 677     $cmd =~ s/^\s+//;
 678     $cmd =~ s/\s+$//;
 679
 680     (my $cmd_word = lc($cmd)) =~ s/^(ss(\.exe)?\s+)?(\S+).*/$3/i;
 681
 682     $cmd = $self->{executable} . " $cmd" unless ($cmd =~ m/^ss(\.exe)?\s/i);
 683
 684     if ($self->{interactive} =~ m/^y/i) {
 685         $cmd = "$cmd -I-Y";
 686     } elsif ($self->{interactive} =~ m/^n/i) {
 687         $cmd = "$cmd -I-N";
 688     } elsif (!$self->{interactive}) {
 689         $cmd = "$cmd -I-"
 690     }
 691
 692     my $disp_cmd = $cmd;
 693
 694     if (defined $self->{user} && $cmd !~ /\s-Y/i) {
 695         if (defined $self->{passwd}) {
 696             $disp_cmd = "$cmd -Y$self->{user},******";
 697             $cmd = "$cmd -Y$self->{user},$self->{passwd}";
 698         } else {
 699             $disp_cmd = $cmd = "$cmd -Y$self->{user}";
 700         }
 701     }
 702
 703     my($rv, $output);
 704
 705     warn "DEBUG: $disp_cmd\n\n" if $self->{_debug};
 706
 707     $ENV{SSDIR} = $self->{database};
 708
 709     if ($self->{use_tempfiles} &&
 710         $cmd_word =~ /^(dir|filetype|history|properties)$/) {
 711         my $tmpfile = "$self->{use_tempfiles}/${cmd_word}_cmd.txt";
 712         unlink $tmpfile;
 713         $cmd = "$cmd \"-O\&$tmpfile\"";
 714         system $cmd;
 715
 716         if (open SS_OUTPUT, "$tmpfile") {
 717             local $/;
 718             $output = scalar <SS_OUTPUT>;
 719             close SS_OUTPUT;
 720             unlink $tmpfile;
 721         } else {
 722             warn "Can't open '$cmd_word' tempfile $tmpfile";
 723             undef $output;
 724         }
 725
 726     } else {
 727         open SS_OUTPUT, '-|', "$cmd 2>&1";
 728
 729         while (<SS_OUTPUT>) {
 730             $output .= $_;
 731         }
 732
 733         close SS_OUTPUT;
 734         $output =~ s/\s+$// if defined $output;
 735     }
 736
 737     if ($silent <= 1) {
 738         if ($self->{paginate}) {
 739             my $linecount = 1;
 740
 741             foreach my $line (split "\n", $output) {
 742                 print "$line\n";
 743
 744                 unless ($linecount++ % $self->{paginate}) {
 745                     print "Hit ENTER to continue...\r";
 746                     <STDIN>;
 747
 748                     print "                        \r";
 749
 750                 }
 751
 752             }
 753
 754         } else {
 755             print "$output\n";
 756         }
 757
 758     }
 759
 760     my $ev = $? >> 8;
 761
 762     # SourceSafe returns 1 to indicate warnings, such as no results returned
 763     # from a 'DIR'. We don't want to consider these an error.
 764     my $success = !($ev > 1);
 765
 766     if ($success) {
 767         # This is interesting. If a command only partially fails (such as GET-ing
 768         # multiple files), that's apparently considered a success. So we have to
 769         # try to fix that.
 770         my $base_cmd = uc($cmd);
 771         $base_cmd =~ s/^(ss\s*)?(\w+).*/$2/i;
 772
 773         my $err_match;
 774
 775         if (defined($err_match = $gErrMatch{$base_cmd}) &&
 776                         $output =~ m/$err_match/m) {
 777             $success = 0;
 778         }
 779
 780     }
 781
 782     if ($success) {
 783         $self->{ss_error} = undef;
 784     } else {
 785         $self->{ss_error} = "$disp_cmd\n$output";
 786     }
 787
 788     if (!$success && ($silent == 0 || $silent == 2)) {
 789
 790         carp "\nERROR in Vss2Svn::VSS-\>ss\n"
 791             . "Command was: $disp_cmd\n   "
 792             . "(Error $ev) $output\n ";
 793         warn "\n";
 794
 795     }
 796
 797     $self->{ss_output} = $output;
 798     return $success;
 799
 800 }  # End ss
 801
 802 ###############################################################################
 803 #  _msg
 804 ###############################################################################
 805 sub _msg {
 806     my $self = shift;
 807     print @_ unless $self->{silent};
 808 }  # End _msg
 809
 810 ###############################################################################
 811 #  _vm  -- "verbose message"
 812 ###############################################################################
 813 sub _vm {
 814     my $self = shift;
 815     print @_ if $self->{verbose};
 816 }  # End _vm
 817
 818 ###############################################################################
 819 #  Initialize
 820 ###############################################################################
 821 sub Initialize {
 822     my $dateFormat = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 823                              . 'International/iDate'} || 0;
 824     my $dateSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 825                              . 'International/sDate'} || '/';
 826     my $timeSep = $Registry->{'HKEY_CURRENT_USER/Control Panel/'
 827                              . 'International/sTime'} || ':';
 828     $gCfg{dateFormat} = $dateFormat;
 829
 830     if ($dateFormat == 1) {
 831         $gCfg{dateString} = "DD${dateSep}MM${dateSep}YY";
 832     } elsif ($dateFormat == 2) {
 833         $gCfg{dateString} = "YY${dateSep}MM${dateSep}DD";
 834     } else {
 835         $gCfg{dateString} = "MM${dateSep}DD${dateSep}YY";
 836     }
 837
 838     $gCfg{timeString} = "HH${timeSep}MM";
 839
 840     # see ss method for explanation of this
 841     %gErrMatch = (
 842                     GET    => 'is not an existing filename or project',
 843                     CREATE => 'Cannot change project to',
 844                     CP     => 'Cannot change project to',
 845                  );
 846
 847     %gHistLineMatch = (
 848         version    => qr/^\*+\s*Version\s+(\d+)\s*\*+\s*$/,
 849         userdttm   => qr/^User:\s+(.*?)\s+
 850                           Date:\s+(\d+)$dateSep(\d+)$dateSep(\d+)\s+
 851                           Time:\s+(\d+)$timeSep(\d+)([ap]*)\s*$/x,
 852         comment    => qr/^(Comment|Label comment): (.*)/,
 853         label      => qr/^Label:\s+"(.*)"/,
 854         stars      => qr/^\*{5,22}/,
 855         stars22    => qr/^\*{22}/,
 856         action     => qr/^(Checked in|Labeled|Created)\s*(.*)/,
 857                                 action0    => qr/^Rolled back/,
 858         action1    => qr/^(.*)\s+(added|deleted|destroyed|purged|recovered|unpinned)$/,
 859         action11   => qr/^\$\/(.*\/)?(.*) shared$/,
 860         action2    => qr/^(.*) renamed to (.*)$/,
 861         action3    => qr/^(.*) pinned to version (.*)$/,
 862         empty      => qr//,
 863     );
 864
 865     # patterns to match development files that project_tree will ignore
 866     @gDevPatterns = (
 867                         qr/\.vspscc$/,
 868                         qr/\.vssscc$/,
 869                         qr/^vssver\.scc$/,
 870                     );
 871
 872 }  # End Initialize
 873
 874 sub first(&@) {
 875         my $code = shift;
 876         &$code && return $_ for @_;
 877         return undef;
 878 }
 879
 880 1;