git-cvsserver.perl

   1 #!/usr/bin/perl
   2
   3 ####
   4 #### This application is a CVS emulation layer for git.
   5 #### It is intended for clients to connect over SSH.
   6 #### See the documentation for more details.
   7 ####
   8 #### Copyright The Open University UK - 2006.
   9 ####
  10 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
  11 ####          Martin Langhoff <martin@catalyst.net.nz>
  12 ####
  13 ####
  14 #### Released under the GNU Public License, version 2.
  15 ####
  16 ####
  17
  18 use strict;
  19 use warnings;
  20 use bytes;
  21
  22 use Fcntl;
  23 use File::Temp qw/tempdir tempfile/;
  24 use File::Path qw/rmtree/;
  25 use File::Basename;
  26 use Getopt::Long qw(:config require_order no_ignore_case);
  27
  28 my $VERSION = '@@GIT_VERSION@@';
  29
  30 my $log = GITCVS::log->new();
  31 my $cfg;
  32
  33 my $DATE_LIST = {
  34     Jan => "01",
  35     Feb => "02",
  36     Mar => "03",
  37     Apr => "04",
  38     May => "05",
  39     Jun => "06",
  40     Jul => "07",
  41     Aug => "08",
  42     Sep => "09",
  43     Oct => "10",
  44     Nov => "11",
  45     Dec => "12",
  46 };
  47
  48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
  49 $| = 1;
  50
  51 #### Definition and mappings of functions ####
  52
  53 my $methods = {
  54     'Root'            => \&req_Root,
  55     'Valid-responses' => \&req_Validresponses,
  56     'valid-requests'  => \&req_validrequests,
  57     'Directory'       => \&req_Directory,
  58     'Entry'           => \&req_Entry,
  59     'Modified'        => \&req_Modified,
  60     'Unchanged'       => \&req_Unchanged,
  61     'Questionable'    => \&req_Questionable,
  62     'Argument'        => \&req_Argument,
  63     'Argumentx'       => \&req_Argument,
  64     'expand-modules'  => \&req_expandmodules,
  65     'add'             => \&req_add,
  66     'remove'          => \&req_remove,
  67     'co'              => \&req_co,
  68     'update'          => \&req_update,
  69     'ci'              => \&req_ci,
  70     'diff'            => \&req_diff,
  71     'log'             => \&req_log,
  72     'rlog'            => \&req_log,
  73     'tag'             => \&req_CATCHALL,
  74     'status'          => \&req_status,
  75     'admin'           => \&req_CATCHALL,
  76     'history'         => \&req_CATCHALL,
  77     'watchers'        => \&req_EMPTY,
  78     'editors'         => \&req_EMPTY,
  79     'noop'            => \&req_EMPTY,
  80     'annotate'        => \&req_annotate,
  81     'Global_option'   => \&req_Globaloption,
  82     #'annotate'        => \&req_CATCHALL,
  83 };
  84
  85 ##############################################
  86
  87
  88 # $state holds all the bits of information the clients sends us that could
  89 # potentially be useful when it comes to actually _doing_ something.
  90 my $state = { prependdir => '' };
  91
  92 # Work is for managing temporary working directory
  93 my $work =
  94     {
  95         state => undef,  # undef, 1 (empty), 2 (with stuff)
  96         workDir => undef,
  97         index => undef,
  98         emptyDir => undef,
  99         tmpDir => undef
 100     };
 101
 102 $log->info("--------------- STARTING -----------------");
 103
 104 my $usage =
 105     "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
 106     "    --base-path <path>  : Prepend to requested CVSROOT\n".
 107     "                          Can be read from GIT_CVSSERVER_BASE_PATH\n".
 108     "    --strict-paths      : Don't allow recursing into subdirectories\n".
 109     "    --export-all        : Don't check for gitcvs.enabled in config\n".
 110     "    --version, -V       : Print version information and exit\n".
 111     "    --help, -h, -H      : Print usage information and exit\n".
 112     "\n".
 113     "<directory> ... is a list of allowed directories. If no directories\n".
 114     "are given, all are allowed. This is an additional restriction, gitcvs\n".
 115     "access still needs to be enabled by the gitcvs.enabled config option.\n".
 116     "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
 117
 118 my @opts = ( 'help|h|H', 'version|V',
 119              'base-path=s', 'strict-paths', 'export-all' );
 120 GetOptions( $state, @opts )
 121     or die $usage;
 122
 123 if ($state->{version}) {
 124     print "git-cvsserver version $VERSION\n";
 125     exit;
 126 }
 127 if ($state->{help}) {
 128     print $usage;
 129     exit;
 130 }
 131
 132 my $TEMP_DIR = tempdir( CLEANUP => 1 );
 133 $log->debug("Temporary directory is '$TEMP_DIR'");
 134
 135 $state->{method} = 'ext';
 136 if (@ARGV) {
 137     if ($ARGV[0] eq 'pserver') {
 138         $state->{method} = 'pserver';
 139         shift @ARGV;
 140     } elsif ($ARGV[0] eq 'server') {
 141         shift @ARGV;
 142     }
 143 }
 144
 145 # everything else is a directory
 146 $state->{allowed_roots} = [ @ARGV ];
 147
 148 # don't export the whole system unless the users requests it
 149 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
 150     die "--export-all can only be used together with an explicit whitelist\n";
 151 }
 152
 153 # Environment handling for running under git-shell
 154 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
 155     if ($state->{'base-path'}) {
 156         die "Cannot specify base path both ways.\n";
 157     }
 158     my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
 159     $state->{'base-path'} = $base_path;
 160     $log->debug("Picked up base path '$base_path' from environment.\n");
 161 }
 162 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
 163     if (@{$state->{allowed_roots}}) {
 164         die "Cannot specify roots both ways: @ARGV\n";
 165     }
 166     my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
 167     $state->{allowed_roots} = [ $allowed_root ];
 168     $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
 169 }
 170
 171 # if we are called with a pserver argument,
 172 # deal with the authentication cat before entering the
 173 # main loop
 174 if ($state->{method} eq 'pserver') {
 175     my $line = <STDIN>; chomp $line;
 176     unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
 177        die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
 178     }
 179     my $request = $1;
 180     $line = <STDIN>; chomp $line;
 181     unless (req_Root('root', $line)) { # reuse Root
 182        print "E Invalid root $line \n";
 183        exit 1;
 184     }
 185     $line = <STDIN>; chomp $line;
 186     my $user = $line;
 187     $line = <STDIN>; chomp $line;
 188     my $password = $line;
 189
 190     if ($user eq 'anonymous') {
 191         # "A" will be 1 byte, use length instead in case the
 192         # encryption method ever changes (yeah, right!)
 193         if (length($password) > 1 ) {
 194             print "E Don't supply a password for the `anonymous' user\n";
 195             print "I HATE YOU\n";
 196             exit 1;
 197         }
 198
 199         # Fall through to LOVE
 200     } else {
 201         # Trying to authenticate a user
 202         if (not exists $cfg->{gitcvs}->{authdb}) {
 203             print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
 204             print "I HATE YOU\n";
 205             exit 1;
 206         }
 207
 208         my $authdb = $cfg->{gitcvs}->{authdb};
 209
 210         unless (-e $authdb) {
 211             print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
 212             print "I HATE YOU\n";
 213             exit 1;
 214         }
 215
 216         my $auth_ok;
 217         open my $passwd, "<", $authdb or die $!;
 218         while (<$passwd>) {
 219             if (m{^\Q$user\E:(.*)}) {
 220                 if (crypt($user, descramble($password)) eq $1) {
 221                     $auth_ok = 1;
 222                 }
 223             };
 224         }
 225         close $passwd;
 226
 227         unless ($auth_ok) {
 228             print "I HATE YOU\n";
 229             exit 1;
 230         }
 231
 232         # Fall through to LOVE
 233     }
 234
 235     # For checking whether the user is anonymous on commit
 236     $state->{user} = $user;
 237
 238     $line = <STDIN>; chomp $line;
 239     unless ($line eq "END $request REQUEST") {
 240        die "E Do not understand $line -- expecting END $request REQUEST\n";
 241     }
 242     print "I LOVE YOU\n";
 243     exit if $request eq 'VERIFICATION'; # cvs login
 244     # and now back to our regular programme...
 245 }
 246
 247 # Keep going until the client closes the connection
 248 while (<STDIN>)
 249 {
 250     chomp;
 251
 252     # Check to see if we've seen this method, and call appropriate function.
 253     if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
 254     {
 255         # use the $methods hash to call the appropriate sub for this command
 256         #$log->info("Method : $1");
 257         &{$methods->{$1}}($1,$2);
 258     } else {
 259         # log fatal because we don't understand this function. If this happens
 260         # we're fairly screwed because we don't know if the client is expecting
 261         # a response. If it is, the client will hang, we'll hang, and the whole
 262         # thing will be custard.
 263         $log->fatal("Don't understand command $_\n");
 264         die("Unknown command $_");
 265     }
 266 }
 267
 268 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
 269 $log->info("--------------- FINISH -----------------");
 270
 271 chdir '/';
 272 exit 0;
 273
 274 # Magic catchall method.
 275 #    This is the method that will handle all commands we haven't yet
 276 #    implemented. It simply sends a warning to the log file indicating a
 277 #    command that hasn't been implemented has been invoked.
 278 sub req_CATCHALL
 279 {
 280     my ( $cmd, $data ) = @_;
 281     $log->warn("Unhandled command : req_$cmd : $data");
 282 }
 283
 284 # This method invariably succeeds with an empty response.
 285 sub req_EMPTY
 286 {
 287     print "ok\n";
 288 }
 289
 290 # Root pathname \n
 291 #     Response expected: no. Tell the server which CVSROOT to use. Note that
 292 #     pathname is a local directory and not a fully qualified CVSROOT variable.
 293 #     pathname must already exist; if creating a new root, use the init
 294 #     request, not Root. pathname does not include the hostname of the server,
 295 #     how to access the server, etc.; by the time the CVS protocol is in use,
 296 #     connection, authentication, etc., are already taken care of. The Root
 297 #     request must be sent only once, and it must be sent before any requests
 298 #     other than Valid-responses, valid-requests, UseUnchanged, Set or init.
 299 sub req_Root
 300 {
 301     my ( $cmd, $data ) = @_;
 302     $log->debug("req_Root : $data");
 303
 304     unless ($data =~ m#^/#) {
 305         print "error 1 Root must be an absolute pathname\n";
 306         return 0;
 307     }
 308
 309     my $cvsroot = $state->{'base-path'} || '';
 310     $cvsroot =~ s#/+$##;
 311     $cvsroot .= $data;
 312
 313     if ($state->{CVSROOT}
 314         && ($state->{CVSROOT} ne $cvsroot)) {
 315         print "error 1 Conflicting roots specified\n";
 316         return 0;
 317     }
 318
 319     $state->{CVSROOT} = $cvsroot;
 320
 321     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 322
 323     if (@{$state->{allowed_roots}}) {
 324         my $allowed = 0;
 325         foreach my $dir (@{$state->{allowed_roots}}) {
 326             next unless $dir =~ m#^/#;
 327             $dir =~ s#/+$##;
 328             if ($state->{'strict-paths'}) {
 329                 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
 330                     $allowed = 1;
 331                     last;
 332                 }
 333             } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
 334                 $allowed = 1;
 335                 last;
 336             }
 337         }
 338
 339         unless ($allowed) {
 340             print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
 341             print "E \n";
 342             print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
 343             return 0;
 344         }
 345     }
 346
 347     unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
 348        print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
 349        print "E \n";
 350        print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
 351        return 0;
 352     }
 353
 354     my @gitvars = `git config -l`;
 355     if ($?) {
 356        print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
 357         print "E \n";
 358         print "error 1 - problem executing git-config\n";
 359        return 0;
 360     }
 361     foreach my $line ( @gitvars )
 362     {
 363         next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
 364         unless ($2) {
 365             $cfg->{$1}{$3} = $4;
 366         } else {
 367             $cfg->{$1}{$2}{$3} = $4;
 368         }
 369     }
 370
 371     my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
 372                    || $cfg->{gitcvs}{enabled});
 373     unless ($state->{'export-all'} ||
 374             ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
 375         print "E GITCVS emulation needs to be enabled on this repo\n";
 376         print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
 377         print "E \n";
 378         print "error 1 GITCVS emulation disabled\n";
 379         return 0;
 380     }
 381
 382     my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
 383     if ( $logfile )
 384     {
 385         $log->setfile($logfile);
 386     } else {
 387         $log->nofile();
 388     }
 389
 390     return 1;
 391 }
 392
 393 # Global_option option \n
 394 #     Response expected: no. Transmit one of the global options `-q', `-Q',
 395 #     `-l', `-t', `-r', or `-n'. option must be one of those strings, no
 396 #     variations (such as combining of options) are allowed. For graceful
 397 #     handling of valid-requests, it is probably better to make new global
 398 #     options separate requests, rather than trying to add them to this
 399 #     request.
 400 sub req_Globaloption
 401 {
 402     my ( $cmd, $data ) = @_;
 403     $log->debug("req_Globaloption : $data");
 404     $state->{globaloptions}{$data} = 1;
 405 }
 406
 407 # Valid-responses request-list \n
 408 #     Response expected: no. Tell the server what responses the client will
 409 #     accept. request-list is a space separated list of tokens.
 410 sub req_Validresponses
 411 {
 412     my ( $cmd, $data ) = @_;
 413     $log->debug("req_Validresponses : $data");
 414
 415     # TODO : re-enable this, currently it's not particularly useful
 416     #$state->{validresponses} = [ split /\s+/, $data ];
 417 }
 418
 419 # valid-requests \n
 420 #     Response expected: yes. Ask the server to send back a Valid-requests
 421 #     response.
 422 sub req_validrequests
 423 {
 424     my ( $cmd, $data ) = @_;
 425
 426     $log->debug("req_validrequests");
 427
 428     $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
 429     $log->debug("SEND : ok");
 430
 431     print "Valid-requests " . join(" ",keys %$methods) . "\n";
 432     print "ok\n";
 433 }
 434
 435 # Directory local-directory \n
 436 #     Additional data: repository \n. Response expected: no. Tell the server
 437 #     what directory to use. The repository should be a directory name from a
 438 #     previous server response. Note that this both gives a default for Entry
 439 #     and Modified and also for ci and the other commands; normal usage is to
 440 #     send Directory for each directory in which there will be an Entry or
 441 #     Modified, and then a final Directory for the original directory, then the
 442 #     command. The local-directory is relative to the top level at which the
 443 #     command is occurring (i.e. the last Directory which is sent before the
 444 #     command); to indicate that top level, `.' should be sent for
 445 #     local-directory.
 446 sub req_Directory
 447 {
 448     my ( $cmd, $data ) = @_;
 449
 450     my $repository = <STDIN>;
 451     chomp $repository;
 452
 453
 454     $state->{localdir} = $data;
 455     $state->{repository} = $repository;
 456     $state->{path} = $repository;
 457     $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
 458     $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
 459     $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
 460
 461     $state->{directory} = $state->{localdir};
 462     $state->{directory} = "" if ( $state->{directory} eq "." );
 463     $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
 464
 465     if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
 466     {
 467         $log->info("Setting prepend to '$state->{path}'");
 468         $state->{prependdir} = $state->{path};
 469         foreach my $entry ( keys %{$state->{entries}} )
 470         {
 471             $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
 472             delete $state->{entries}{$entry};
 473         }
 474     }
 475
 476     if ( defined ( $state->{prependdir} ) )
 477     {
 478         $log->debug("Prepending '$state->{prependdir}' to state|directory");
 479         $state->{directory} = $state->{prependdir} . $state->{directory}
 480     }
 481     $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
 482 }
 483
 484 # Entry entry-line \n
 485 #     Response expected: no. Tell the server what version of a file is on the
 486 #     local machine. The name in entry-line is a name relative to the directory
 487 #     most recently specified with Directory. If the user is operating on only
 488 #     some files in a directory, Entry requests for only those files need be
 489 #     included. If an Entry request is sent without Modified, Is-modified, or
 490 #     Unchanged, it means the file is lost (does not exist in the working
 491 #     directory). If both Entry and one of Modified, Is-modified, or Unchanged
 492 #     are sent for the same file, Entry must be sent first. For a given file,
 493 #     one can send Modified, Is-modified, or Unchanged, but not more than one
 494 #     of these three.
 495 sub req_Entry
 496 {
 497     my ( $cmd, $data ) = @_;
 498
 499     #$log->debug("req_Entry : $data");
 500
 501     my @data = split(/\//, $data);
 502
 503     $state->{entries}{$state->{directory}.$data[1]} = {
 504         revision    => $data[2],
 505         conflict    => $data[3],
 506         options     => $data[4],
 507         tag_or_date => $data[5],
 508     };
 509
 510     $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
 511 }
 512
 513 # Questionable filename \n
 514 #     Response expected: no. Additional data: no. Tell the server to check
 515 #     whether filename should be ignored, and if not, next time the server
 516 #     sends responses, send (in a M response) `?' followed by the directory and
 517 #     filename. filename must not contain `/'; it needs to be a file in the
 518 #     directory named by the most recent Directory request.
 519 sub req_Questionable
 520 {
 521     my ( $cmd, $data ) = @_;
 522
 523     $log->debug("req_Questionable : $data");
 524     $state->{entries}{$state->{directory}.$data}{questionable} = 1;
 525 }
 526
 527 # add \n
 528 #     Response expected: yes. Add a file or directory. This uses any previous
 529 #     Argument, Directory, Entry, or Modified requests, if they have been sent.
 530 #     The last Directory sent specifies the working directory at the time of
 531 #     the operation. To add a directory, send the directory to be added using
 532 #     Directory and Argument requests.
 533 sub req_add
 534 {
 535     my ( $cmd, $data ) = @_;
 536
 537     argsplit("add");
 538
 539     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 540     $updater->update();
 541
 542     argsfromdir($updater);
 543
 544     my $addcount = 0;
 545
 546     foreach my $filename ( @{$state->{args}} )
 547     {
 548         $filename = filecleanup($filename);
 549
 550         my $meta = $updater->getmeta($filename);
 551         my $wrev = revparse($filename);
 552
 553         if ($wrev && $meta && ($wrev < 0))
 554         {
 555             # previously removed file, add back
 556             $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
 557
 558             print "MT +updated\n";
 559             print "MT text U \n";
 560             print "MT fname $filename\n";
 561             print "MT newline\n";
 562             print "MT -updated\n";
 563
 564             unless ( $state->{globaloptions}{-n} )
 565             {
 566                 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
 567
 568                 print "Created $dirpart\n";
 569                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 570
 571                 # this is an "entries" line
 572                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
 573                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
 574                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
 575                 # permissions
 576                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
 577                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
 578                 # transmit file
 579                 transmitfile($meta->{filehash});
 580             }
 581
 582             next;
 583         }
 584
 585         unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
 586         {
 587             print "E cvs add: nothing known about `$filename'\n";
 588             next;
 589         }
 590         # TODO : check we're not squashing an already existing file
 591         if ( defined ( $state->{entries}{$filename}{revision} ) )
 592         {
 593             print "E cvs add: `$filename' has already been entered\n";
 594             next;
 595         }
 596
 597         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
 598
 599         print "E cvs add: scheduling file `$filename' for addition\n";
 600
 601         print "Checked-in $dirpart\n";
 602         print "$filename\n";
 603         my $kopts = kopts_from_path($filename,"file",
 604                         $state->{entries}{$filename}{modified_filename});
 605         print "/$filepart/0//$kopts/\n";
 606
 607         my $requestedKopts = $state->{opt}{k};
 608         if(defined($requestedKopts))
 609         {
 610             $requestedKopts = "-k$requestedKopts";
 611         }
 612         else
 613         {
 614             $requestedKopts = "";
 615         }
 616         if( $kopts ne $requestedKopts )
 617         {
 618             $log->warn("Ignoring requested -k='$requestedKopts'"
 619                         . " for '$filename'; detected -k='$kopts' instead");
 620             #TODO: Also have option to send warning to user?
 621         }
 622
 623         $addcount++;
 624     }
 625
 626     if ( $addcount == 1 )
 627     {
 628         print "E cvs add: use `cvs commit' to add this file permanently\n";
 629     }
 630     elsif ( $addcount > 1 )
 631     {
 632         print "E cvs add: use `cvs commit' to add these files permanently\n";
 633     }
 634
 635     print "ok\n";
 636 }
 637
 638 # remove \n
 639 #     Response expected: yes. Remove a file. This uses any previous Argument,
 640 #     Directory, Entry, or Modified requests, if they have been sent. The last
 641 #     Directory sent specifies the working directory at the time of the
 642 #     operation. Note that this request does not actually do anything to the
 643 #     repository; the only effect of a successful remove request is to supply
 644 #     the client with a new entries line containing `-' to indicate a removed
 645 #     file. In fact, the client probably could perform this operation without
 646 #     contacting the server, although using remove may cause the server to
 647 #     perform a few more checks. The client sends a subsequent ci request to
 648 #     actually record the removal in the repository.
 649 sub req_remove
 650 {
 651     my ( $cmd, $data ) = @_;
 652
 653     argsplit("remove");
 654
 655     # Grab a handle to the SQLite db and do any necessary updates
 656     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 657     $updater->update();
 658
 659     #$log->debug("add state : " . Dumper($state));
 660
 661     my $rmcount = 0;
 662
 663     foreach my $filename ( @{$state->{args}} )
 664     {
 665         $filename = filecleanup($filename);
 666
 667         if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
 668         {
 669             print "E cvs remove: file `$filename' still in working directory\n";
 670             next;
 671         }
 672
 673         my $meta = $updater->getmeta($filename);
 674         my $wrev = revparse($filename);
 675
 676         unless ( defined ( $wrev ) )
 677         {
 678             print "E cvs remove: nothing known about `$filename'\n";
 679             next;
 680         }
 681
 682         if ( defined($wrev) and $wrev < 0 )
 683         {
 684             print "E cvs remove: file `$filename' already scheduled for removal\n";
 685             next;
 686         }
 687
 688         unless ( $wrev == $meta->{revision} )
 689         {
 690             # TODO : not sure if the format of this message is quite correct.
 691             print "E cvs remove: Up to date check failed for `$filename'\n";
 692             next;
 693         }
 694
 695
 696         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
 697
 698         print "E cvs remove: scheduling `$filename' for removal\n";
 699
 700         print "Checked-in $dirpart\n";
 701         print "$filename\n";
 702         my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
 703         print "/$filepart/-1.$wrev//$kopts/\n";
 704
 705         $rmcount++;
 706     }
 707
 708     if ( $rmcount == 1 )
 709     {
 710         print "E cvs remove: use `cvs commit' to remove this file permanently\n";
 711     }
 712     elsif ( $rmcount > 1 )
 713     {
 714         print "E cvs remove: use `cvs commit' to remove these files permanently\n";
 715     }
 716
 717     print "ok\n";
 718 }
 719
 720 # Modified filename \n
 721 #     Response expected: no. Additional data: mode, \n, file transmission. Send
 722 #     the server a copy of one locally modified file. filename is a file within
 723 #     the most recent directory sent with Directory; it must not contain `/'.
 724 #     If the user is operating on only some files in a directory, only those
 725 #     files need to be included. This can also be sent without Entry, if there
 726 #     is no entry for the file.
 727 sub req_Modified
 728 {
 729     my ( $cmd, $data ) = @_;
 730
 731     my $mode = <STDIN>;
 732     defined $mode
 733         or (print "E end of file reading mode for $data\n"), return;
 734     chomp $mode;
 735     my $size = <STDIN>;
 736     defined $size
 737         or (print "E end of file reading size of $data\n"), return;
 738     chomp $size;
 739
 740     # Grab config information
 741     my $blocksize = 8192;
 742     my $bytesleft = $size;
 743     my $tmp;
 744
 745     # Get a filehandle/name to write it to
 746     my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
 747
 748     # Loop over file data writing out to temporary file.
 749     while ( $bytesleft )
 750     {
 751         $blocksize = $bytesleft if ( $bytesleft < $blocksize );
 752         read STDIN, $tmp, $blocksize;
 753         print $fh $tmp;
 754         $bytesleft -= $blocksize;
 755     }
 756
 757     close $fh
 758         or (print "E failed to write temporary, $filename: $!\n"), return;
 759
 760     # Ensure we have something sensible for the file mode
 761     if ( $mode =~ /u=(\w+)/ )
 762     {
 763         $mode = $1;
 764     } else {
 765         $mode = "rw";
 766     }
 767
 768     # Save the file data in $state
 769     $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
 770     $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
 771     $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
 772     $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
 773
 774     #$log->debug("req_Modified : file=$data mode=$mode size=$size");
 775 }
 776
 777 # Unchanged filename \n
 778 #     Response expected: no. Tell the server that filename has not been
 779 #     modified in the checked out directory. The filename is a file within the
 780 #     most recent directory sent with Directory; it must not contain `/'.
 781 sub req_Unchanged
 782 {
 783     my ( $cmd, $data ) = @_;
 784
 785     $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
 786
 787     #$log->debug("req_Unchanged : $data");
 788 }
 789
 790 # Argument text \n
 791 #     Response expected: no. Save argument for use in a subsequent command.
 792 #     Arguments accumulate until an argument-using command is given, at which
 793 #     point they are forgotten.
 794 # Argumentx text \n
 795 #     Response expected: no. Append \n followed by text to the current argument
 796 #     being saved.
 797 sub req_Argument
 798 {
 799     my ( $cmd, $data ) = @_;
 800
 801     # Argumentx means: append to last Argument (with a newline in front)
 802
 803     $log->debug("$cmd : $data");
 804
 805     if ( $cmd eq 'Argumentx') {
 806         ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
 807     } else {
 808         push @{$state->{arguments}}, $data;
 809     }
 810 }
 811
 812 # expand-modules \n
 813 #     Response expected: yes. Expand the modules which are specified in the
 814 #     arguments. Returns the data in Module-expansion responses. Note that the
 815 #     server can assume that this is checkout or export, not rtag or rdiff; the
 816 #     latter do not access the working directory and thus have no need to
 817 #     expand modules on the client side. Expand may not be the best word for
 818 #     what this request does. It does not necessarily tell you all the files
 819 #     contained in a module, for example. Basically it is a way of telling you
 820 #     which working directories the server needs to know about in order to
 821 #     handle a checkout of the specified modules. For example, suppose that the
 822 #     server has a module defined by
 823 #   aliasmodule -a 1dir
 824 #     That is, one can check out aliasmodule and it will take 1dir in the
 825 #     repository and check it out to 1dir in the working directory. Now suppose
 826 #     the client already has this module checked out and is planning on using
 827 #     the co request to update it. Without using expand-modules, the client
 828 #     would have two bad choices: it could either send information about all
 829 #     working directories under the current directory, which could be
 830 #     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
 831 #     stands for 1dir, and neglect to send information for 1dir, which would
 832 #     lead to incorrect operation. With expand-modules, the client would first
 833 #     ask for the module to be expanded:
 834 sub req_expandmodules
 835 {
 836     my ( $cmd, $data ) = @_;
 837
 838     argsplit();
 839
 840     $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
 841
 842     unless ( ref $state->{arguments} eq "ARRAY" )
 843     {
 844         print "ok\n";
 845         return;
 846     }
 847
 848     foreach my $module ( @{$state->{arguments}} )
 849     {
 850         $log->debug("SEND : Module-expansion $module");
 851         print "Module-expansion $module\n";
 852     }
 853
 854     print "ok\n";
 855     statecleanup();
 856 }
 857
 858 # co \n
 859 #     Response expected: yes. Get files from the repository. This uses any
 860 #     previous Argument, Directory, Entry, or Modified requests, if they have
 861 #     been sent. Arguments to this command are module names; the client cannot
 862 #     know what directories they correspond to except by (1) just sending the
 863 #     co request, and then seeing what directory names the server sends back in
 864 #     its responses, and (2) the expand-modules request.
 865 sub req_co
 866 {
 867     my ( $cmd, $data ) = @_;
 868
 869     argsplit("co");
 870
 871     # Provide list of modules, if -c was used.
 872     if (exists $state->{opt}{c}) {
 873         my $showref = `git show-ref --heads`;
 874         for my $line (split '\n', $showref) {
 875             if ( $line =~ m% refs/heads/(.*)$% ) {
 876                 print "M $1\t$1\n";
 877             }
 878         }
 879         print "ok\n";
 880         return 1;
 881     }
 882
 883     my $module = $state->{args}[0];
 884     $state->{module} = $module;
 885     my $checkout_path = $module;
 886
 887     # use the user specified directory if we're given it
 888     $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
 889
 890     $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
 891
 892     $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
 893
 894     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 895
 896     # Grab a handle to the SQLite db and do any necessary updates
 897     my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
 898     $updater->update();
 899
 900     $checkout_path =~ s|/$||; # get rid of trailing slashes
 901
 902     # Eclipse seems to need the Clear-sticky command
 903     # to prepare the 'Entries' file for the new directory.
 904     print "Clear-sticky $checkout_path/\n";
 905     print $state->{CVSROOT} . "/$module/\n";
 906     print "Clear-static-directory $checkout_path/\n";
 907     print $state->{CVSROOT} . "/$module/\n";
 908     print "Clear-sticky $checkout_path/\n"; # yes, twice
 909     print $state->{CVSROOT} . "/$module/\n";
 910     print "Template $checkout_path/\n";
 911     print $state->{CVSROOT} . "/$module/\n";
 912     print "0\n";
 913
 914     # instruct the client that we're checking out to $checkout_path
 915     print "E cvs checkout: Updating $checkout_path\n";
 916
 917     my %seendirs = ();
 918     my $lastdir ='';
 919
 920     # recursive
 921     sub prepdir {
 922        my ($dir, $repodir, $remotedir, $seendirs) = @_;
 923        my $parent = dirname($dir);
 924        $dir       =~ s|/+$||;
 925        $repodir   =~ s|/+$||;
 926        $remotedir =~ s|/+$||;
 927        $parent    =~ s|/+$||;
 928        $log->debug("announcedir $dir, $repodir, $remotedir" );
 929
 930        if ($parent eq '.' || $parent eq './') {
 931            $parent = '';
 932        }
 933        # recurse to announce unseen parents first
 934        if (length($parent) && !exists($seendirs->{$parent})) {
 935            prepdir($parent, $repodir, $remotedir, $seendirs);
 936        }
 937        # Announce that we are going to modify at the parent level
 938        if ($parent) {
 939            print "E cvs checkout: Updating $remotedir/$parent\n";
 940        } else {
 941            print "E cvs checkout: Updating $remotedir\n";
 942        }
 943        print "Clear-sticky $remotedir/$parent/\n";
 944        print "$repodir/$parent/\n";
 945
 946        print "Clear-static-directory $remotedir/$dir/\n";
 947        print "$repodir/$dir/\n";
 948        print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
 949        print "$repodir/$parent/\n";
 950        print "Template $remotedir/$dir/\n";
 951        print "$repodir/$dir/\n";
 952        print "0\n";
 953
 954        $seendirs->{$dir} = 1;
 955     }
 956
 957     foreach my $git ( @{$updater->gethead} )
 958     {
 959         # Don't want to check out deleted files
 960         next if ( $git->{filehash} eq "deleted" );
 961
 962         my $fullName = $git->{name};
 963         ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
 964
 965        if (length($git->{dir}) && $git->{dir} ne './'
 966            && $git->{dir} ne $lastdir ) {
 967            unless (exists($seendirs{$git->{dir}})) {
 968                prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
 969                        $checkout_path, \%seendirs);
 970                $lastdir = $git->{dir};
 971                $seendirs{$git->{dir}} = 1;
 972            }
 973            print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
 974        }
 975
 976         # modification time of this file
 977         print "Mod-time $git->{modified}\n";
 978
 979         # print some information to the client
 980         if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
 981         {
 982             print "M U $checkout_path/$git->{dir}$git->{name}\n";
 983         } else {
 984             print "M U $checkout_path/$git->{name}\n";
 985         }
 986
 987        # instruct client we're sending a file to put in this path
 988        print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
 989
 990        print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
 991
 992         # this is an "entries" line
 993         my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
 994         print "/$git->{name}/1.$git->{revision}//$kopts/\n";
 995         # permissions
 996         print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
 997
 998         # transmit file
 999         transmitfile($git->{filehash});
1000     }
1001
1002     print "ok\n";
1003
1004     statecleanup();
1005 }
1006
1007 # update \n
1008 #     Response expected: yes. Actually do a cvs update command. This uses any
1009 #     previous Argument, Directory, Entry, or Modified requests, if they have
1010 #     been sent. The last Directory sent specifies the working directory at the
1011 #     time of the operation. The -I option is not used--files which the client
1012 #     can decide whether to ignore are not mentioned and the client sends the
1013 #     Questionable request for others.
1014 sub req_update
1015 {
1016     my ( $cmd, $data ) = @_;
1017
1018     $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1019
1020     argsplit("update");
1021
1022     #
1023     # It may just be a client exploring the available heads/modules
1024     # in that case, list them as top level directories and leave it
1025     # at that. Eclipse uses this technique to offer you a list of
1026     # projects (heads in this case) to checkout.
1027     #
1028     if ($state->{module} eq '') {
1029         my $showref = `git show-ref --heads`;
1030         print "E cvs update: Updating .\n";
1031         for my $line (split '\n', $showref) {
1032             if ( $line =~ m% refs/heads/(.*)$% ) {
1033                 print "E cvs update: New directory `$1'\n";
1034             }
1035         }
1036         print "ok\n";
1037         return 1;
1038     }
1039
1040
1041     # Grab a handle to the SQLite db and do any necessary updates
1042     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1043
1044     $updater->update();
1045
1046     argsfromdir($updater);
1047
1048     #$log->debug("update state : " . Dumper($state));
1049
1050     my $last_dirname = "///";
1051
1052     # foreach file specified on the command line ...
1053     foreach my $filename ( @{$state->{args}} )
1054     {
1055         $filename = filecleanup($filename);
1056
1057         $log->debug("Processing file $filename");
1058
1059         unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1060         {
1061             my $cur_dirname = dirname($filename);
1062             if ( $cur_dirname ne $last_dirname )
1063             {
1064                 $last_dirname = $cur_dirname;
1065                 if ( $cur_dirname eq "" )
1066                 {
1067                     $cur_dirname = ".";
1068                 }
1069                 print "E cvs update: Updating $cur_dirname\n";
1070             }
1071         }
1072
1073         # if we have a -C we should pretend we never saw modified stuff
1074         if ( exists ( $state->{opt}{C} ) )
1075         {
1076             delete $state->{entries}{$filename}{modified_hash};
1077             delete $state->{entries}{$filename}{modified_filename};
1078             $state->{entries}{$filename}{unchanged} = 1;
1079         }
1080
1081         my $meta;
1082         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1083         {
1084             $meta = $updater->getmeta($filename, $1);
1085         } else {
1086             $meta = $updater->getmeta($filename);
1087         }
1088
1089         # If -p was given, "print" the contents of the requested revision.
1090         if ( exists ( $state->{opt}{p} ) ) {
1091             if ( defined ( $meta->{revision} ) ) {
1092                 $log->info("Printing '$filename' revision " . $meta->{revision});
1093
1094                 transmitfile($meta->{filehash}, { print => 1 });
1095             }
1096
1097             next;
1098         }
1099
1100         if ( ! defined $meta )
1101         {
1102             $meta = {
1103                 name => $filename,
1104                 revision => 0,
1105                 filehash => 'added'
1106             };
1107         }
1108
1109         my $oldmeta = $meta;
1110
1111         my $wrev = revparse($filename);
1112
1113         # If the working copy is an old revision, lets get that version too for comparison.
1114         if ( defined($wrev) and $wrev != $meta->{revision} )
1115         {
1116             $oldmeta = $updater->getmeta($filename, $wrev);
1117         }
1118
1119         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1120
1121         # Files are up to date if the working copy and repo copy have the same revision,
1122         # and the working copy is unmodified _and_ the user hasn't specified -C
1123         next if ( defined ( $wrev )
1124                   and defined($meta->{revision})
1125                   and $wrev == $meta->{revision}
1126                   and $state->{entries}{$filename}{unchanged}
1127                   and not exists ( $state->{opt}{C} ) );
1128
1129         # If the working copy and repo copy have the same revision,
1130         # but the working copy is modified, tell the client it's modified
1131         if ( defined ( $wrev )
1132              and defined($meta->{revision})
1133              and $wrev == $meta->{revision}
1134              and defined($state->{entries}{$filename}{modified_hash})
1135              and not exists ( $state->{opt}{C} ) )
1136         {
1137             $log->info("Tell the client the file is modified");
1138             print "MT text M \n";
1139             print "MT fname $filename\n";
1140             print "MT newline\n";
1141             next;
1142         }
1143
1144         if ( $meta->{filehash} eq "deleted" )
1145         {
1146             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1147
1148             $log->info("Removing '$filename' from working copy (no longer in the repo)");
1149
1150             print "E cvs update: `$filename' is no longer in the repository\n";
1151             # Don't want to actually _DO_ the update if -n specified
1152             unless ( $state->{globaloptions}{-n} ) {
1153                 print "Removed $dirpart\n";
1154                 print "$filepart\n";
1155             }
1156         }
1157         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1158                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1159                 or $meta->{filehash} eq 'added' )
1160         {
1161             # normal update, just send the new revision (either U=Update,
1162             # or A=Add, or R=Remove)
1163             if ( defined($wrev) && $wrev < 0 )
1164             {
1165                 $log->info("Tell the client the file is scheduled for removal");
1166                 print "MT text R \n";
1167                 print "MT fname $filename\n";
1168                 print "MT newline\n";
1169                 next;
1170             }
1171             elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1172             {
1173                 $log->info("Tell the client the file is scheduled for addition");
1174                 print "MT text A \n";
1175                 print "MT fname $filename\n";
1176                 print "MT newline\n";
1177                 next;
1178
1179             }
1180             else {
1181                 $log->info("Updating '$filename' to ".$meta->{revision});
1182                 print "MT +updated\n";
1183                 print "MT text U \n";
1184                 print "MT fname $filename\n";
1185                 print "MT newline\n";
1186                 print "MT -updated\n";
1187             }
1188
1189             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1190
1191             # Don't want to actually _DO_ the update if -n specified
1192             unless ( $state->{globaloptions}{-n} )
1193             {
1194                 if ( defined ( $wrev ) )
1195                 {
1196                     # instruct client we're sending a file to put in this path as a replacement
1197                     print "Update-existing $dirpart\n";
1198                     $log->debug("Updating existing file 'Update-existing $dirpart'");
1199                 } else {
1200                     # instruct client we're sending a file to put in this path as a new file
1201                     print "Clear-static-directory $dirpart\n";
1202                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1203                     print "Clear-sticky $dirpart\n";
1204                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1205
1206                     $log->debug("Creating new file 'Created $dirpart'");
1207                     print "Created $dirpart\n";
1208                 }
1209                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1210
1211                 # this is an "entries" line
1212                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1213                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1214                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1215
1216                 # permissions
1217                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1218                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1219
1220                 # transmit file
1221                 transmitfile($meta->{filehash});
1222             }
1223         } else {
1224             $log->info("Updating '$filename'");
1225             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1226
1227             my $mergeDir = setupTmpDir();
1228
1229             my $file_local = $filepart . ".mine";
1230             my $mergedFile = "$mergeDir/$file_local";
1231             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1232             my $file_old = $filepart . "." . $oldmeta->{revision};
1233             transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1234             my $file_new = $filepart . "." . $meta->{revision};
1235             transmitfile($meta->{filehash}, { targetfile => $file_new });
1236
1237             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1238             $log->info("Merging $file_local, $file_old, $file_new");
1239             print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1240
1241             $log->debug("Temporary directory for merge is $mergeDir");
1242
1243             my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1244             $return >>= 8;
1245
1246             cleanupTmpDir();
1247
1248             if ( $return == 0 )
1249             {
1250                 $log->info("Merged successfully");
1251                 print "M M $filename\n";
1252                 $log->debug("Merged $dirpart");
1253
1254                 # Don't want to actually _DO_ the update if -n specified
1255                 unless ( $state->{globaloptions}{-n} )
1256                 {
1257                     print "Merged $dirpart\n";
1258                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1259                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1260                     my $kopts = kopts_from_path("$dirpart/$filepart",
1261                                                 "file",$mergedFile);
1262                     $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1263                     print "/$filepart/1.$meta->{revision}//$kopts/\n";
1264                 }
1265             }
1266             elsif ( $return == 1 )
1267             {
1268                 $log->info("Merged with conflicts");
1269                 print "E cvs update: conflicts found in $filename\n";
1270                 print "M C $filename\n";
1271
1272                 # Don't want to actually _DO_ the update if -n specified
1273                 unless ( $state->{globaloptions}{-n} )
1274                 {
1275                     print "Merged $dirpart\n";
1276                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1277                     my $kopts = kopts_from_path("$dirpart/$filepart",
1278                                                 "file",$mergedFile);
1279                     print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1280                 }
1281             }
1282             else
1283             {
1284                 $log->warn("Merge failed");
1285                 next;
1286             }
1287
1288             # Don't want to actually _DO_ the update if -n specified
1289             unless ( $state->{globaloptions}{-n} )
1290             {
1291                 # permissions
1292                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1293                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1294
1295                 # transmit file, format is single integer on a line by itself (file
1296                 # size) followed by the file contents
1297                 # TODO : we should copy files in blocks
1298                 my $data = `cat $mergedFile`;
1299                 $log->debug("File size : " . length($data));
1300                 print length($data) . "\n";
1301                 print $data;
1302             }
1303         }
1304
1305     }
1306
1307     print "ok\n";
1308 }
1309
1310 sub req_ci
1311 {
1312     my ( $cmd, $data ) = @_;
1313
1314     argsplit("ci");
1315
1316     #$log->debug("State : " . Dumper($state));
1317
1318     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1319
1320     if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1321     {
1322         print "error 1 anonymous user cannot commit via pserver\n";
1323         cleanupWorkTree();
1324         exit;
1325     }
1326
1327     if ( -e $state->{CVSROOT} . "/index" )
1328     {
1329         $log->warn("file 'index' already exists in the git repository");
1330         print "error 1 Index already exists in git repo\n";
1331         cleanupWorkTree();
1332         exit;
1333     }
1334
1335     # Grab a handle to the SQLite db and do any necessary updates
1336     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1337     $updater->update();
1338
1339     # Remember where the head was at the beginning.
1340     my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1341     chomp $parenthash;
1342     if ($parenthash !~ /^[0-9a-f]{40}$/) {
1343             print "error 1 pserver cannot find the current HEAD of module";
1344             cleanupWorkTree();
1345             exit;
1346     }
1347
1348     setupWorkTree($parenthash);
1349
1350     $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1351
1352     $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1353
1354     my @committedfiles = ();
1355     my %oldmeta;
1356
1357     # foreach file specified on the command line ...
1358     foreach my $filename ( @{$state->{args}} )
1359     {
1360         my $committedfile = $filename;
1361         $filename = filecleanup($filename);
1362
1363         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1364
1365         my $meta = $updater->getmeta($filename);
1366         $oldmeta{$filename} = $meta;
1367
1368         my $wrev = revparse($filename);
1369
1370         my ( $filepart, $dirpart ) = filenamesplit($filename);
1371
1372         # do a checkout of the file if it is part of this tree
1373         if ($wrev) {
1374             system('git', 'checkout-index', '-f', '-u', $filename);
1375             unless ($? == 0) {
1376                 die "Error running git-checkout-index -f -u $filename : $!";
1377             }
1378         }
1379
1380         my $addflag = 0;
1381         my $rmflag = 0;
1382         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1383         $addflag = 1 unless ( -e $filename );
1384
1385         # Do up to date checking
1386         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1387         {
1388             # fail everything if an up to date check fails
1389             print "error 1 Up to date check failed for $filename\n";
1390             cleanupWorkTree();
1391             exit;
1392         }
1393
1394         push @committedfiles, $committedfile;
1395         $log->info("Committing $filename");
1396
1397         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1398
1399         unless ( $rmflag )
1400         {
1401             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1402             rename $state->{entries}{$filename}{modified_filename},$filename;
1403
1404             # Calculate modes to remove
1405             my $invmode = "";
1406             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1407
1408             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1409             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1410         }
1411
1412         if ( $rmflag )
1413         {
1414             $log->info("Removing file '$filename'");
1415             unlink($filename);
1416             system("git", "update-index", "--remove", $filename);
1417         }
1418         elsif ( $addflag )
1419         {
1420             $log->info("Adding file '$filename'");
1421             system("git", "update-index", "--add", $filename);
1422         } else {
1423             $log->info("Updating file '$filename'");
1424             system("git", "update-index", $filename);
1425         }
1426     }
1427
1428     unless ( scalar(@committedfiles) > 0 )
1429     {
1430         print "E No files to commit\n";
1431         print "ok\n";
1432         cleanupWorkTree();
1433         return;
1434     }
1435
1436     my $treehash = `git write-tree`;
1437     chomp $treehash;
1438
1439     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1440
1441     # write our commit message out if we have one ...
1442     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1443     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1444     if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1445         if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1446             print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1447         }
1448     } else {
1449         print $msg_fh "\n\nvia git-CVS emulator\n";
1450     }
1451     close $msg_fh;
1452
1453     my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1454     chomp($commithash);
1455     $log->info("Commit hash : $commithash");
1456
1457     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1458     {
1459         $log->warn("Commit failed (Invalid commit hash)");
1460         print "error 1 Commit failed (unknown reason)\n";
1461         cleanupWorkTree();
1462         exit;
1463     }
1464
1465         ### Emulate git-receive-pack by running hooks/update
1466         my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1467                         $parenthash, $commithash );
1468         if( -x $hook[0] ) {
1469                 unless( system( @hook ) == 0 )
1470                 {
1471                         $log->warn("Commit failed (update hook declined to update ref)");
1472                         print "error 1 Commit failed (update hook declined)\n";
1473                         cleanupWorkTree();
1474                         exit;
1475                 }
1476         }
1477
1478         ### Update the ref
1479         if (system(qw(git update-ref -m), "cvsserver ci",
1480                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1481                 $log->warn("update-ref for $state->{module} failed.");
1482                 print "error 1 Cannot commit -- update first\n";
1483                 cleanupWorkTree();
1484                 exit;
1485         }
1486
1487         ### Emulate git-receive-pack by running hooks/post-receive
1488         my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1489         if( -x $hook ) {
1490                 open(my $pipe, "| $hook") || die "can't fork $!";
1491
1492                 local $SIG{PIPE} = sub { die 'pipe broke' };
1493
1494                 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1495
1496                 close $pipe || die "bad pipe: $! $?";
1497         }
1498
1499     $updater->update();
1500
1501         ### Then hooks/post-update
1502         $hook = $ENV{GIT_DIR}.'hooks/post-update';
1503         if (-x $hook) {
1504                 system($hook, "refs/heads/$state->{module}");
1505         }
1506
1507     # foreach file specified on the command line ...
1508     foreach my $filename ( @committedfiles )
1509     {
1510         $filename = filecleanup($filename);
1511
1512         my $meta = $updater->getmeta($filename);
1513         unless (defined $meta->{revision}) {
1514           $meta->{revision} = 1;
1515         }
1516
1517         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1518
1519         $log->debug("Checked-in $dirpart : $filename");
1520
1521         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1522         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1523         {
1524             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1525             print "Remove-entry $dirpart\n";
1526             print "$filename\n";
1527         } else {
1528             if ($meta->{revision} == 1) {
1529                 print "M initial revision: 1.1\n";
1530             } else {
1531                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1532             }
1533             print "Checked-in $dirpart\n";
1534             print "$filename\n";
1535             my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1536             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1537         }
1538     }
1539
1540     cleanupWorkTree();
1541     print "ok\n";
1542 }
1543
1544 sub req_status
1545 {
1546     my ( $cmd, $data ) = @_;
1547
1548     argsplit("status");
1549
1550     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1551     #$log->debug("status state : " . Dumper($state));
1552
1553     # Grab a handle to the SQLite db and do any necessary updates
1554     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1555     $updater->update();
1556
1557     # if no files were specified, we need to work out what files we should be providing status on ...
1558     argsfromdir($updater);
1559
1560     # foreach file specified on the command line ...
1561     foreach my $filename ( @{$state->{args}} )
1562     {
1563         $filename = filecleanup($filename);
1564
1565         next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1566
1567         my $meta = $updater->getmeta($filename);
1568         my $oldmeta = $meta;
1569
1570         my $wrev = revparse($filename);
1571
1572         # If the working copy is an old revision, lets get that version too for comparison.
1573         if ( defined($wrev) and $wrev != $meta->{revision} )
1574         {
1575             $oldmeta = $updater->getmeta($filename, $wrev);
1576         }
1577
1578         # TODO : All possible statuses aren't yet implemented
1579         my $status;
1580         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1581         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1582                                     and
1583                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1584                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1585                                    );
1586
1587         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1588         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1589                                           and
1590                                           ( $state->{entries}{$filename}{unchanged}
1591                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1592                                         );
1593
1594         # Need checkout if it exists in the repo but doesn't have a working copy
1595         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1596
1597         # Locally modified if working copy and repo copy have the same revision but there are local changes
1598         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1599
1600         # Needs Merge if working copy revision is less than repo copy and there are local changes
1601         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1602
1603         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1604         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1605         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1606         $status ||= "File had conflicts on merge" if ( 0 );
1607
1608         $status ||= "Unknown";
1609
1610         my ($filepart) = filenamesplit($filename);
1611
1612         print "M ===================================================================\n";
1613         print "M File: $filepart\tStatus: $status\n";
1614         if ( defined($state->{entries}{$filename}{revision}) )
1615         {
1616             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1617         } else {
1618             print "M Working revision:\tNo entry for $filename\n";
1619         }
1620         if ( defined($meta->{revision}) )
1621         {
1622             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1623             print "M Sticky Tag:\t\t(none)\n";
1624             print "M Sticky Date:\t\t(none)\n";
1625             print "M Sticky Options:\t\t(none)\n";
1626         } else {
1627             print "M Repository revision:\tNo revision control file\n";
1628         }
1629         print "M\n";
1630     }
1631
1632     print "ok\n";
1633 }
1634
1635 sub req_diff
1636 {
1637     my ( $cmd, $data ) = @_;
1638
1639     argsplit("diff");
1640
1641     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1642     #$log->debug("status state : " . Dumper($state));
1643
1644     my ($revision1, $revision2);
1645     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1646     {
1647         $revision1 = $state->{opt}{r}[0];
1648         $revision2 = $state->{opt}{r}[1];
1649     } else {
1650         $revision1 = $state->{opt}{r};
1651     }
1652
1653     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1654     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1655
1656     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1657
1658     # Grab a handle to the SQLite db and do any necessary updates
1659     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1660     $updater->update();
1661
1662     # if no files were specified, we need to work out what files we should be providing status on ...
1663     argsfromdir($updater);
1664
1665     # foreach file specified on the command line ...
1666     foreach my $filename ( @{$state->{args}} )
1667     {
1668         $filename = filecleanup($filename);
1669
1670         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1671
1672         my $wrev = revparse($filename);
1673
1674         # We need _something_ to diff against
1675         next unless ( defined ( $wrev ) );
1676
1677         # if we have a -r switch, use it
1678         if ( defined ( $revision1 ) )
1679         {
1680             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1681             $meta1 = $updater->getmeta($filename, $revision1);
1682             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1683             {
1684                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1685                 next;
1686             }
1687             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1688         }
1689         # otherwise we just use the working copy revision
1690         else
1691         {
1692             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1693             $meta1 = $updater->getmeta($filename, $wrev);
1694             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1695         }
1696
1697         # if we have a second -r switch, use it too
1698         if ( defined ( $revision2 ) )
1699         {
1700             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1701             $meta2 = $updater->getmeta($filename, $revision2);
1702
1703             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1704             {
1705                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1706                 next;
1707             }
1708
1709             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1710         }
1711         # otherwise we just use the working copy
1712         else
1713         {
1714             $file2 = $state->{entries}{$filename}{modified_filename};
1715         }
1716
1717         # if we have been given -r, and we don't have a $file2 yet, lets get one
1718         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1719         {
1720             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1721             $meta2 = $updater->getmeta($filename, $wrev);
1722             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1723         }
1724
1725         # We need to have retrieved something useful
1726         next unless ( defined ( $meta1 ) );
1727
1728         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1729         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1730                   and
1731                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1732                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1733                   );
1734
1735         # Apparently we only show diffs for locally modified files
1736         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1737
1738         print "M Index: $filename\n";
1739         print "M ===================================================================\n";
1740         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1741         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1742         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1743         print "M diff ";
1744         foreach my $opt ( keys %{$state->{opt}} )
1745         {
1746             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1747             {
1748                 foreach my $value ( @{$state->{opt}{$opt}} )
1749                 {
1750                     print "-$opt $value ";
1751                 }
1752             } else {
1753                 print "-$opt ";
1754                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1755             }
1756         }
1757         print "$filename\n";
1758
1759         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1760
1761         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1762
1763         if ( exists $state->{opt}{u} )
1764         {
1765             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1766         } else {
1767             system("diff $file1 $file2 > $filediff");
1768         }
1769
1770         while ( <$fh> )
1771         {
1772             print "M $_";
1773         }
1774         close $fh;
1775     }
1776
1777     print "ok\n";
1778 }
1779
1780 sub req_log
1781 {
1782     my ( $cmd, $data ) = @_;
1783
1784     argsplit("log");
1785
1786     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1787     #$log->debug("log state : " . Dumper($state));
1788
1789     my ( $minrev, $maxrev );
1790     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1791     {
1792         my $control = $2;
1793         $minrev = $1;
1794         $maxrev = $3;
1795         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1796         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1797         $minrev++ if ( defined($minrev) and $control eq "::" );
1798     }
1799
1800     # Grab a handle to the SQLite db and do any necessary updates
1801     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1802     $updater->update();
1803
1804     # if no files were specified, we need to work out what files we should be providing status on ...
1805     argsfromdir($updater);
1806
1807     # foreach file specified on the command line ...
1808     foreach my $filename ( @{$state->{args}} )
1809     {
1810         $filename = filecleanup($filename);
1811
1812         my $headmeta = $updater->getmeta($filename);
1813
1814         my $revisions = $updater->getlog($filename);
1815         my $totalrevisions = scalar(@$revisions);
1816
1817         if ( defined ( $minrev ) )
1818         {
1819             $log->debug("Removing revisions less than $minrev");
1820             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1821             {
1822                 pop @$revisions;
1823             }
1824         }
1825         if ( defined ( $maxrev ) )
1826         {
1827             $log->debug("Removing revisions greater than $maxrev");
1828             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1829             {
1830                 shift @$revisions;
1831             }
1832         }
1833
1834         next unless ( scalar(@$revisions) );
1835
1836         print "M \n";
1837         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1838         print "M Working file: $filename\n";
1839         print "M head: 1.$headmeta->{revision}\n";
1840         print "M branch:\n";
1841         print "M locks: strict\n";
1842         print "M access list:\n";
1843         print "M symbolic names:\n";
1844         print "M keyword substitution: kv\n";
1845         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1846         print "M description:\n";
1847
1848         foreach my $revision ( @$revisions )
1849         {
1850             print "M ----------------------------\n";
1851             print "M revision 1.$revision->{revision}\n";
1852             # reformat the date for log output
1853             $revision->{modified} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1854             $revision->{author} = cvs_author($revision->{author});
1855             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1856             my $commitmessage = $updater->commitmessage($revision->{commithash});
1857             $commitmessage =~ s/^/M /mg;
1858             print $commitmessage . "\n";
1859         }
1860         print "M =============================================================================\n";
1861     }
1862
1863     print "ok\n";
1864 }
1865
1866 sub req_annotate
1867 {
1868     my ( $cmd, $data ) = @_;
1869
1870     argsplit("annotate");
1871
1872     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1873     #$log->debug("status state : " . Dumper($state));
1874
1875     # Grab a handle to the SQLite db and do any necessary updates
1876     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1877     $updater->update();
1878
1879     # if no files were specified, we need to work out what files we should be providing annotate on ...
1880     argsfromdir($updater);
1881
1882     # we'll need a temporary checkout dir
1883     setupWorkTree();
1884
1885     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1886
1887     # foreach file specified on the command line ...
1888     foreach my $filename ( @{$state->{args}} )
1889     {
1890         $filename = filecleanup($filename);
1891
1892         my $meta = $updater->getmeta($filename);
1893
1894         next unless ( $meta->{revision} );
1895
1896         # get all the commits that this file was in
1897         # in dense format -- aka skip dead revisions
1898         my $revisions   = $updater->gethistorydense($filename);
1899         my $lastseenin  = $revisions->[0][2];
1900
1901         # populate the temporary index based on the latest commit were we saw
1902         # the file -- but do it cheaply without checking out any files
1903         # TODO: if we got a revision from the client, use that instead
1904         # to look up the commithash in sqlite (still good to default to
1905         # the current head as we do now)
1906         system("git", "read-tree", $lastseenin);
1907         unless ($? == 0)
1908         {
1909             print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1910             return;
1911         }
1912         $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1913
1914         # do a checkout of the file
1915         system('git', 'checkout-index', '-f', '-u', $filename);
1916         unless ($? == 0) {
1917             print "E error running git-checkout-index -f -u $filename : $!\n";
1918             return;
1919         }
1920
1921         $log->info("Annotate $filename");
1922
1923         # Prepare a file with the commits from the linearized
1924         # history that annotate should know about. This prevents
1925         # git-jsannotate telling us about commits we are hiding
1926         # from the client.
1927
1928         my $a_hints = "$work->{workDir}/.annotate_hints";
1929         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1930             print "E failed to open '$a_hints' for writing: $!\n";
1931             return;
1932         }
1933         for (my $i=0; $i < @$revisions; $i++)
1934         {
1935             print ANNOTATEHINTS $revisions->[$i][2];
1936             if ($i+1 < @$revisions) { # have we got a parent?
1937                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1938             }
1939             print ANNOTATEHINTS "\n";
1940         }
1941
1942         print ANNOTATEHINTS "\n";
1943         close ANNOTATEHINTS
1944             or (print "E failed to write $a_hints: $!\n"), return;
1945
1946         my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1947         if (!open(ANNOTATE, "-|", @cmd)) {
1948             print "E error invoking ". join(' ',@cmd) .": $!\n";
1949             return;
1950         }
1951         my $metadata = {};
1952         print "E Annotations for $filename\n";
1953         print "E ***************\n";
1954         while ( <ANNOTATE> )
1955         {
1956             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1957             {
1958                 my $commithash = $1;
1959                 my $data = $2;
1960                 unless ( defined ( $metadata->{$commithash} ) )
1961                 {
1962                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1963                     $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1964                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1965                 }
1966                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1967                     $metadata->{$commithash}{revision},
1968                     $metadata->{$commithash}{author},
1969                     $metadata->{$commithash}{modified},
1970                     $data
1971                 );
1972             } else {
1973                 $log->warn("Error in annotate output! LINE: $_");
1974                 print "E Annotate error \n";
1975                 next;
1976             }
1977         }
1978         close ANNOTATE;
1979     }
1980
1981     # done; get out of the tempdir
1982     cleanupWorkTree();
1983
1984     print "ok\n";
1985
1986 }
1987
1988 # This method takes the state->{arguments} array and produces two new arrays.
1989 # The first is $state->{args} which is everything before the '--' argument, and
1990 # the second is $state->{files} which is everything after it.
1991 sub argsplit
1992 {
1993     $state->{args} = [];
1994     $state->{files} = [];
1995     $state->{opt} = {};
1996
1997     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1998
1999     my $type = shift;
2000
2001     if ( defined($type) )
2002     {
2003         my $opt = {};
2004         $opt = { A => 0, N => 0, P => 0, R => 0, c => 0, f => 0, l => 0, n => 0, p => 0, s => 0, r => 1, D => 1, d => 1, k => 1, j => 1, } if ( $type eq "co" );
2005         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2006         $opt = { A => 0, P => 0, C => 0, d => 0, f => 0, l => 0, R => 0, p => 0, k => 1, r => 1, D => 1, j => 1, I => 1, W => 1 } if ( $type eq "update" );
2007         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2008         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2009         $opt = { k => 1, m => 1 } if ( $type eq "add" );
2010         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2011         $opt = { l => 0, b => 0, h => 0, R => 0, t => 0, N => 0, S => 0, r => 1, d => 1, s => 1, w => 1 } if ( $type eq "log" );
2012
2013
2014         while ( scalar ( @{$state->{arguments}} ) > 0 )
2015         {
2016             my $arg = shift @{$state->{arguments}};
2017
2018             next if ( $arg eq "--" );
2019             next unless ( $arg =~ /\S/ );
2020
2021             # if the argument looks like a switch
2022             if ( $arg =~ /^-(\w)(.*)/ )
2023             {
2024                 # if it's a switch that takes an argument
2025                 if ( $opt->{$1} )
2026                 {
2027                     # If this switch has already been provided
2028                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2029                     {
2030                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
2031                         if ( length($2) > 0 )
2032                         {
2033                             push @{$state->{opt}{$1}},$2;
2034                         } else {
2035                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2036                         }
2037                     } else {
2038                         # if there's extra data in the arg, use that as the argument for the switch
2039                         if ( length($2) > 0 )
2040                         {
2041                             $state->{opt}{$1} = $2;
2042                         } else {
2043                             $state->{opt}{$1} = shift @{$state->{arguments}};
2044                         }
2045                     }
2046                 } else {
2047                     $state->{opt}{$1} = undef;
2048                 }
2049             }
2050             else
2051             {
2052                 push @{$state->{args}}, $arg;
2053             }
2054         }
2055     }
2056     else
2057     {
2058         my $mode = 0;
2059
2060         foreach my $value ( @{$state->{arguments}} )
2061         {
2062             if ( $value eq "--" )
2063             {
2064                 $mode++;
2065                 next;
2066             }
2067             push @{$state->{args}}, $value if ( $mode == 0 );
2068             push @{$state->{files}}, $value if ( $mode == 1 );
2069         }
2070     }
2071 }
2072
2073 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2074 sub argsfromdir
2075 {
2076     my $updater = shift;
2077
2078     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2079
2080     return if ( scalar ( @{$state->{args}} ) > 1 );
2081
2082     my @gethead = @{$updater->gethead};
2083
2084     # push added files
2085     foreach my $file (keys %{$state->{entries}}) {
2086         if ( exists $state->{entries}{$file}{revision} &&
2087                 $state->{entries}{$file}{revision} == 0 )
2088         {
2089             push @gethead, { name => $file, filehash => 'added' };
2090         }
2091     }
2092
2093     if ( scalar(@{$state->{args}}) == 1 )
2094     {
2095         my $arg = $state->{args}[0];
2096         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2097
2098         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2099
2100         foreach my $file ( @gethead )
2101         {
2102             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2103             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
2104             push @{$state->{args}}, $file->{name};
2105         }
2106
2107         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2108     } else {
2109         $log->info("Only one arg specified, populating file list automatically");
2110
2111         $state->{args} = [];
2112
2113         foreach my $file ( @gethead )
2114         {
2115             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2116             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2117             push @{$state->{args}}, $file->{name};
2118         }
2119     }
2120 }
2121
2122 # This method cleans up the $state variable after a command that uses arguments has run
2123 sub statecleanup
2124 {
2125     $state->{files} = [];
2126     $state->{args} = [];
2127     $state->{arguments} = [];
2128     $state->{entries} = {};
2129 }
2130
2131 sub revparse
2132 {
2133     my $filename = shift;
2134
2135     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2136
2137     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2138     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2139
2140     return undef;
2141 }
2142
2143 # This method takes a file hash and does a CVS "file transfer".  Its
2144 # exact behaviour depends on a second, optional hash table argument:
2145 # - If $options->{targetfile}, dump the contents to that file;
2146 # - If $options->{print}, use M/MT to transmit the contents one line
2147 #   at a time;
2148 # - Otherwise, transmit the size of the file, followed by the file
2149 #   contents.
2150 sub transmitfile
2151 {
2152     my $filehash = shift;
2153     my $options = shift;
2154
2155     if ( defined ( $filehash ) and $filehash eq "deleted" )
2156     {
2157         $log->warn("filehash is 'deleted'");
2158         return;
2159     }
2160
2161     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2162
2163     my $type = `git cat-file -t $filehash`;
2164     chomp $type;
2165
2166     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2167
2168     my $size = `git cat-file -s $filehash`;
2169     chomp $size;
2170
2171     $log->debug("transmitfile($filehash) size=$size, type=$type");
2172
2173     if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2174     {
2175         if ( defined ( $options->{targetfile} ) )
2176         {
2177             my $targetfile = $options->{targetfile};
2178             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2179             print NEWFILE $_ while ( <$fh> );
2180             close NEWFILE or die("Failed to write '$targetfile': $!");
2181         } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2182             while ( <$fh> ) {
2183                 if( /\n\z/ ) {
2184                     print 'M ', $_;
2185                 } else {
2186                     print 'MT text ', $_, "\n";
2187                 }
2188             }
2189         } else {
2190             print "$size\n";
2191             print while ( <$fh> );
2192         }
2193         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2194     } else {
2195         die("Couldn't execute git-cat-file");
2196     }
2197 }
2198
2199 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2200 # refers to the directory portion and the file portion of the filename
2201 # respectively
2202 sub filenamesplit
2203 {
2204     my $filename = shift;
2205     my $fixforlocaldir = shift;
2206
2207     my ( $filepart, $dirpart ) = ( $filename, "." );
2208     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2209     $dirpart .= "/";
2210
2211     if ( $fixforlocaldir )
2212     {
2213         $dirpart =~ s/^$state->{prependdir}//;
2214     }
2215
2216     return ( $filepart, $dirpart );
2217 }
2218
2219 sub filecleanup
2220 {
2221     my $filename = shift;
2222
2223     return undef unless(defined($filename));
2224     if ( $filename =~ /^\// )
2225     {
2226         print "E absolute filenames '$filename' not supported by server\n";
2227         return undef;
2228     }
2229
2230     $filename =~ s/^\.\///g;
2231     $filename = $state->{prependdir} . $filename;
2232     return $filename;
2233 }
2234
2235 sub validateGitDir
2236 {
2237     if( !defined($state->{CVSROOT}) )
2238     {
2239         print "error 1 CVSROOT not specified\n";
2240         cleanupWorkTree();
2241         exit;
2242     }
2243     if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2244     {
2245         print "error 1 Internally inconsistent CVSROOT\n";
2246         cleanupWorkTree();
2247         exit;
2248     }
2249 }
2250
2251 # Setup working directory in a work tree with the requested version
2252 # loaded in the index.
2253 sub setupWorkTree
2254 {
2255     my ($ver) = @_;
2256
2257     validateGitDir();
2258
2259     if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2260         defined($work->{tmpDir}) )
2261     {
2262         $log->warn("Bad work tree state management");
2263         print "error 1 Internal setup multiple work trees without cleanup\n";
2264         cleanupWorkTree();
2265         exit;
2266     }
2267
2268     $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2269
2270     if( !defined($work->{index}) )
2271     {
2272         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2273     }
2274
2275     chdir $work->{workDir} or
2276         die "Unable to chdir to $work->{workDir}\n";
2277
2278     $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2279
2280     $ENV{GIT_WORK_TREE} = ".";
2281     $ENV{GIT_INDEX_FILE} = $work->{index};
2282     $work->{state} = 2;
2283
2284     if($ver)
2285     {
2286         system("git","read-tree",$ver);
2287         unless ($? == 0)
2288         {
2289             $log->warn("Error running git-read-tree");
2290             die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2291         }
2292     }
2293     # else # req_annotate reads tree for each file
2294 }
2295
2296 # Ensure current directory is in some kind of working directory,
2297 # with a recent version loaded in the index.
2298 sub ensureWorkTree
2299 {
2300     if( defined($work->{tmpDir}) )
2301     {
2302         $log->warn("Bad work tree state management [ensureWorkTree()]");
2303         print "error 1 Internal setup multiple dirs without cleanup\n";
2304         cleanupWorkTree();
2305         exit;
2306     }
2307     if( $work->{state} )
2308     {
2309         return;
2310     }
2311
2312     validateGitDir();
2313
2314     if( !defined($work->{emptyDir}) )
2315     {
2316         $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2317     }
2318     chdir $work->{emptyDir} or
2319         die "Unable to chdir to $work->{emptyDir}\n";
2320
2321     my $ver = `git show-ref -s refs/heads/$state->{module}`;
2322     chomp $ver;
2323     if ($ver !~ /^[0-9a-f]{40}$/)
2324     {
2325         $log->warn("Error from git show-ref -s refs/head$state->{module}");
2326         print "error 1 cannot find the current HEAD of module";
2327         cleanupWorkTree();
2328         exit;
2329     }
2330
2331     if( !defined($work->{index}) )
2332     {
2333         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2334     }
2335
2336     $ENV{GIT_WORK_TREE} = ".";
2337     $ENV{GIT_INDEX_FILE} = $work->{index};
2338     $work->{state} = 1;
2339
2340     system("git","read-tree",$ver);
2341     unless ($? == 0)
2342     {
2343         die "Error running git-read-tree $ver $!\n";
2344     }
2345 }
2346
2347 # Cleanup working directory that is not needed any longer.
2348 sub cleanupWorkTree
2349 {
2350     if( ! $work->{state} )
2351     {
2352         return;
2353     }
2354
2355     chdir "/" or die "Unable to chdir '/'\n";
2356
2357     if( defined($work->{workDir}) )
2358     {
2359         rmtree( $work->{workDir} );
2360         undef $work->{workDir};
2361     }
2362     undef $work->{state};
2363 }
2364
2365 # Setup a temporary directory (not a working tree), typically for
2366 # merging dirty state as in req_update.
2367 sub setupTmpDir
2368 {
2369     $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2370     chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2371
2372     return $work->{tmpDir};
2373 }
2374
2375 # Clean up a previously setupTmpDir.  Restore previous work tree if
2376 # appropriate.
2377 sub cleanupTmpDir
2378 {
2379     if ( !defined($work->{tmpDir}) )
2380     {
2381         $log->warn("cleanup tmpdir that has not been setup");
2382         die "Cleanup tmpDir that has not been setup\n";
2383     }
2384     if( defined($work->{state}) )
2385     {
2386         if( $work->{state} == 1 )
2387         {
2388             chdir $work->{emptyDir} or
2389                 die "Unable to chdir to $work->{emptyDir}\n";
2390         }
2391         elsif( $work->{state} == 2 )
2392         {
2393             chdir $work->{workDir} or
2394                 die "Unable to chdir to $work->{emptyDir}\n";
2395         }
2396         else
2397         {
2398             $log->warn("Inconsistent work dir state");
2399             die "Inconsistent work dir state\n";
2400         }
2401     }
2402     else
2403     {
2404         chdir "/" or die "Unable to chdir '/'\n";
2405     }
2406 }
2407
2408 # Given a path, this function returns a string containing the kopts
2409 # that should go into that path's Entries line.  For example, a binary
2410 # file should get -kb.
2411 sub kopts_from_path
2412 {
2413     my ($path, $srcType, $name) = @_;
2414
2415     if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2416          $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2417     {
2418         my ($val) = check_attr( "text", $path );
2419         if ( $val eq "unspecified" )
2420         {
2421             $val = check_attr( "crlf", $path );
2422         }
2423         if ( $val eq "unset" )
2424         {
2425             return "-kb"
2426         }
2427         elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2428                 $val eq "set" || $val eq "input" )
2429         {
2430             return "";
2431         }
2432         else
2433         {
2434             $log->info("Unrecognized check_attr crlf $path : $val");
2435         }
2436     }
2437
2438     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2439     {
2440         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2441         {
2442             return "-kb";
2443         }
2444         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2445         {
2446             if( $srcType eq "sha1Or-k" &&
2447                 !defined($name) )
2448             {
2449                 my ($ret)=$state->{entries}{$path}{options};
2450                 if( !defined($ret) )
2451                 {
2452                     $ret=$state->{opt}{k};
2453                     if(defined($ret))
2454                     {
2455                         $ret="-k$ret";
2456                     }
2457                     else
2458                     {
2459                         $ret="";
2460                     }
2461                 }
2462                 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2463                 {
2464                     print "E Bad -k option\n";
2465                     $log->warn("Bad -k option: $ret");
2466                     die "Error: Bad -k option: $ret\n";
2467                 }
2468
2469                 return $ret;
2470             }
2471             else
2472             {
2473                 if( is_binary($srcType,$name) )
2474                 {
2475                     $log->debug("... as binary");
2476                     return "-kb";
2477                 }
2478                 else
2479                 {
2480                     $log->debug("... as text");
2481                 }
2482             }
2483         }
2484     }
2485     # Return "" to give no special treatment to any path
2486     return "";
2487 }
2488
2489 sub check_attr
2490 {
2491     my ($attr,$path) = @_;
2492     ensureWorkTree();
2493     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2494     {
2495         my $val = <$fh>;
2496         close $fh;
2497         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2498         return $val;
2499     }
2500     else
2501     {
2502         return undef;
2503     }
2504 }
2505
2506 # This should have the same heuristics as convert.c:is_binary() and related.
2507 # Note that the bare CR test is done by callers in convert.c.
2508 sub is_binary
2509 {
2510     my ($srcType,$name) = @_;
2511     $log->debug("is_binary($srcType,$name)");
2512
2513     # Minimize amount of interpreted code run in the inner per-character
2514     # loop for large files, by totalling each character value and
2515     # then analyzing the totals.
2516     my @counts;
2517     my $i;
2518     for($i=0;$i<256;$i++)
2519     {
2520         $counts[$i]=0;
2521     }
2522
2523     my $fh = open_blob_or_die($srcType,$name);
2524     my $line;
2525     while( defined($line=<$fh>) )
2526     {
2527         # Any '\0' and bare CR are considered binary.
2528         if( $line =~ /\0|(\r[^\n])/ )
2529         {
2530             close($fh);
2531             return 1;
2532         }
2533
2534         # Count up each character in the line:
2535         my $len=length($line);
2536         for($i=0;$i<$len;$i++)
2537         {
2538             $counts[ord(substr($line,$i,1))]++;
2539         }
2540     }
2541     close $fh;
2542
2543     # Don't count CR and LF as either printable/nonprintable
2544     $counts[ord("\n")]=0;
2545     $counts[ord("\r")]=0;
2546
2547     # Categorize individual character count into printable and nonprintable:
2548     my $printable=0;
2549     my $nonprintable=0;
2550     for($i=0;$i<256;$i++)
2551     {
2552         if( $i < 32 &&
2553             $i != ord("\b") &&
2554             $i != ord("\t") &&
2555             $i != 033 &&       # ESC
2556             $i != 014 )        # FF
2557         {
2558             $nonprintable+=$counts[$i];
2559         }
2560         elsif( $i==127 )  # DEL
2561         {
2562             $nonprintable+=$counts[$i];
2563         }
2564         else
2565         {
2566             $printable+=$counts[$i];
2567         }
2568     }
2569
2570     return ($printable >> 7) < $nonprintable;
2571 }
2572
2573 # Returns open file handle.  Possible invocations:
2574 #  - open_blob_or_die("file",$filename);
2575 #  - open_blob_or_die("sha1",$filehash);
2576 sub open_blob_or_die
2577 {
2578     my ($srcType,$name) = @_;
2579     my ($fh);
2580     if( $srcType eq "file" )
2581     {
2582         if( !open $fh,"<",$name )
2583         {
2584             $log->warn("Unable to open file $name: $!");
2585             die "Unable to open file $name: $!\n";
2586         }
2587     }
2588     elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2589     {
2590         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2591         {
2592             $log->warn("Need filehash");
2593             die "Need filehash\n";
2594         }
2595
2596         my $type = `git cat-file -t $name`;
2597         chomp $type;
2598
2599         unless ( defined ( $type ) and $type eq "blob" )
2600         {
2601             $log->warn("Invalid type '$type' for '$name'");
2602             die ( "Invalid type '$type' (expected 'blob')" )
2603         }
2604
2605         my $size = `git cat-file -s $name`;
2606         chomp $size;
2607
2608         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2609
2610         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2611         {
2612             $log->warn("Unable to open sha1 $name");
2613             die "Unable to open sha1 $name\n";
2614         }
2615     }
2616     else
2617     {
2618         $log->warn("Unknown type of blob source: $srcType");
2619         die "Unknown type of blob source: $srcType\n";
2620     }
2621     return $fh;
2622 }
2623
2624 # Generate a CVS author name from Git author information, by taking the local
2625 # part of the email address and replacing characters not in the Portable
2626 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2627 # Login names are Unix login names, which should be restricted to this
2628 # character set.
2629 sub cvs_author
2630 {
2631     my $author_line = shift;
2632     (my $author) = $author_line =~ /<([^@>]*)/;
2633
2634     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2635     $author =~ s/^-/_/;
2636
2637     $author;
2638 }
2639
2640
2641 sub descramble
2642 {
2643     # This table is from src/scramble.c in the CVS source
2644     my @SHIFTS = (
2645         0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
2646         16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2647         114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2648         111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2649         41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2650         125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2651         36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2652         58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2653         225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2654         199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2655         174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2656         207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2657         192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2658         227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2659         182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2660         243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2661     );
2662     my ($str) = @_;
2663
2664     # This should never happen, the same password format (A) has been
2665     # used by CVS since the beginning of time
2666     {
2667         my $fmt = substr($str, 0, 1);
2668         die "invalid password format `$fmt'" unless $fmt eq 'A';
2669     }
2670
2671     my @str = unpack "C*", substr($str, 1);
2672     my $ret = join '', map { chr $SHIFTS[$_] } @str;
2673     return $ret;
2674 }
2675
2676
2677 package GITCVS::log;
2678
2679 ####
2680 #### Copyright The Open University UK - 2006.
2681 ####
2682 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2683 ####          Martin Langhoff <martin@catalyst.net.nz>
2684 ####
2685 ####
2686
2687 use strict;
2688 use warnings;
2689
2690 =head1 NAME
2691
2692 GITCVS::log
2693
2694 =head1 DESCRIPTION
2695
2696 This module provides very crude logging with a similar interface to
2697 Log::Log4perl
2698
2699 =head1 METHODS
2700
2701 =cut
2702
2703 =head2 new
2704
2705 Creates a new log object, optionally you can specify a filename here to
2706 indicate the file to log to. If no log file is specified, you can specify one
2707 later with method setfile, or indicate you no longer want logging with method
2708 nofile.
2709
2710 Until one of these methods is called, all log calls will buffer messages ready
2711 to write out.
2712
2713 =cut
2714 sub new
2715 {
2716     my $class = shift;
2717     my $filename = shift;
2718
2719     my $self = {};
2720
2721     bless $self, $class;
2722
2723     if ( defined ( $filename ) )
2724     {
2725         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2726     }
2727
2728     return $self;
2729 }
2730
2731 =head2 setfile
2732
2733 This methods takes a filename, and attempts to open that file as the log file.
2734 If successful, all buffered data is written out to the file, and any further
2735 logging is written directly to the file.
2736
2737 =cut
2738 sub setfile
2739 {
2740     my $self = shift;
2741     my $filename = shift;
2742
2743     if ( defined ( $filename ) )
2744     {
2745         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2746     }
2747
2748     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2749
2750     while ( my $line = shift @{$self->{buffer}} )
2751     {
2752         print {$self->{fh}} $line;
2753     }
2754 }
2755
2756 =head2 nofile
2757
2758 This method indicates no logging is going to be used. It flushes any entries in
2759 the internal buffer, and sets a flag to ensure no further data is put there.
2760
2761 =cut
2762 sub nofile
2763 {
2764     my $self = shift;
2765
2766     $self->{nolog} = 1;
2767
2768     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2769
2770     $self->{buffer} = [];
2771 }
2772
2773 =head2 _logopen
2774
2775 Internal method. Returns true if the log file is open, false otherwise.
2776
2777 =cut
2778 sub _logopen
2779 {
2780     my $self = shift;
2781
2782     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2783     return 0;
2784 }
2785
2786 =head2 debug info warn fatal
2787
2788 These four methods are wrappers to _log. They provide the actual interface for
2789 logging data.
2790
2791 =cut
2792 sub debug { my $self = shift; $self->_log("debug", @_); }
2793 sub info  { my $self = shift; $self->_log("info" , @_); }
2794 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2795 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2796
2797 =head2 _log
2798
2799 This is an internal method called by the logging functions. It generates a
2800 timestamp and pushes the logged line either to file, or internal buffer.
2801
2802 =cut
2803 sub _log
2804 {
2805     my $self = shift;
2806     my $level = shift;
2807
2808     return if ( $self->{nolog} );
2809
2810     my @time = localtime;
2811     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2812         $time[5] + 1900,
2813         $time[4] + 1,
2814         $time[3],
2815         $time[2],
2816         $time[1],
2817         $time[0],
2818         uc $level,
2819     );
2820
2821     if ( $self->_logopen )
2822     {
2823         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2824     } else {
2825         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2826     }
2827 }
2828
2829 =head2 DESTROY
2830
2831 This method simply closes the file handle if one is open
2832
2833 =cut
2834 sub DESTROY
2835 {
2836     my $self = shift;
2837
2838     if ( $self->_logopen )
2839     {
2840         close $self->{fh};
2841     }
2842 }
2843
2844 package GITCVS::updater;
2845
2846 ####
2847 #### Copyright The Open University UK - 2006.
2848 ####
2849 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2850 ####          Martin Langhoff <martin@catalyst.net.nz>
2851 ####
2852 ####
2853
2854 use strict;
2855 use warnings;
2856 use DBI;
2857
2858 =head1 METHODS
2859
2860 =cut
2861
2862 =head2 new
2863
2864 =cut
2865 sub new
2866 {
2867     my $class = shift;
2868     my $config = shift;
2869     my $module = shift;
2870     my $log = shift;
2871
2872     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2873     die "Need to specify a module" unless ( defined($module) );
2874
2875     $class = ref($class) || $class;
2876
2877     my $self = {};
2878
2879     bless $self, $class;
2880
2881     $self->{valid_tables} = {'revision' => 1,
2882                              'revision_ix1' => 1,
2883                              'revision_ix2' => 1,
2884                              'head' => 1,
2885                              'head_ix1' => 1,
2886                              'properties' => 1,
2887                              'commitmsgs' => 1};
2888
2889     $self->{module} = $module;
2890     $self->{git_path} = $config . "/";
2891
2892     $self->{log} = $log;
2893
2894     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2895
2896     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2897         $cfg->{gitcvs}{dbdriver} || "SQLite";
2898     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2899         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2900     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2901         $cfg->{gitcvs}{dbuser} || "";
2902     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2903         $cfg->{gitcvs}{dbpass} || "";
2904     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2905         $cfg->{gitcvs}{dbtablenameprefix} || "";
2906     my %mapping = ( m => $module,
2907                     a => $state->{method},
2908                     u => getlogin || getpwuid($<) || $<,
2909                     G => $self->{git_path},
2910                     g => mangle_dirname($self->{git_path}),
2911                     );
2912     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2913     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2914     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2915     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2916
2917     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2918     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2919     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2920                                 $self->{dbuser},
2921                                 $self->{dbpass});
2922     die "Error connecting to database\n" unless defined $self->{dbh};
2923
2924     $self->{tables} = {};
2925     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2926     {
2927         $self->{tables}{$table} = 1;
2928     }
2929
2930     # Construct the revision table if required
2931     unless ( $self->{tables}{$self->tablename("revision")} )
2932     {
2933         my $tablename = $self->tablename("revision");
2934         my $ix1name = $self->tablename("revision_ix1");
2935         my $ix2name = $self->tablename("revision_ix2");
2936         $self->{dbh}->do("
2937             CREATE TABLE $tablename (
2938                 name       TEXT NOT NULL,
2939                 revision   INTEGER NOT NULL,
2940                 filehash   TEXT NOT NULL,
2941                 commithash TEXT NOT NULL,
2942                 author     TEXT NOT NULL,
2943                 modified   TEXT NOT NULL,
2944                 mode       TEXT NOT NULL
2945             )
2946         ");
2947         $self->{dbh}->do("
2948             CREATE INDEX $ix1name
2949             ON $tablename (name,revision)
2950         ");
2951         $self->{dbh}->do("
2952             CREATE INDEX $ix2name
2953             ON $tablename (name,commithash)
2954         ");
2955     }
2956
2957     # Construct the head table if required
2958     unless ( $self->{tables}{$self->tablename("head")} )
2959     {
2960         my $tablename = $self->tablename("head");
2961         my $ix1name = $self->tablename("head_ix1");
2962         $self->{dbh}->do("
2963             CREATE TABLE $tablename (
2964                 name       TEXT NOT NULL,
2965                 revision   INTEGER NOT NULL,
2966                 filehash   TEXT NOT NULL,
2967                 commithash TEXT NOT NULL,
2968                 author     TEXT NOT NULL,
2969                 modified   TEXT NOT NULL,
2970                 mode       TEXT NOT NULL
2971             )
2972         ");
2973         $self->{dbh}->do("
2974             CREATE INDEX $ix1name
2975             ON $tablename (name)
2976         ");
2977     }
2978
2979     # Construct the properties table if required
2980     unless ( $self->{tables}{$self->tablename("properties")} )
2981     {
2982         my $tablename = $self->tablename("properties");
2983         $self->{dbh}->do("
2984             CREATE TABLE $tablename (
2985                 key        TEXT NOT NULL PRIMARY KEY,
2986                 value      TEXT
2987             )
2988         ");
2989     }
2990
2991     # Construct the commitmsgs table if required
2992     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2993     {
2994         my $tablename = $self->tablename("commitmsgs");
2995         $self->{dbh}->do("
2996             CREATE TABLE $tablename (
2997                 key        TEXT NOT NULL PRIMARY KEY,
2998                 value      TEXT
2999             )
3000         ");
3001     }
3002
3003     return $self;
3004 }
3005
3006 =head2 tablename
3007
3008 =cut
3009 sub tablename
3010 {
3011     my $self = shift;
3012     my $name = shift;
3013
3014     if (exists $self->{valid_tables}{$name}) {
3015         return $self->{dbtablenameprefix} . $name;
3016     } else {
3017         return undef;
3018     }
3019 }
3020
3021 =head2 update
3022
3023 =cut
3024 sub update
3025 {
3026     my $self = shift;
3027
3028     # first lets get the commit list
3029     $ENV{GIT_DIR} = $self->{git_path};
3030
3031     my $commitsha1 = `git rev-parse $self->{module}`;
3032     chomp $commitsha1;
3033
3034     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3035     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3036     {
3037         die("Invalid module '$self->{module}'");
3038     }
3039
3040
3041     my $git_log;
3042     my $lastcommit = $self->_get_prop("last_commit");
3043
3044     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3045          return 1;
3046     }
3047
3048     # Start exclusive lock here...
3049     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3050
3051     # TODO: log processing is memory bound
3052     # if we can parse into a 2nd file that is in reverse order
3053     # we can probably do something really efficient
3054     my @git_log_params = ('--pretty', '--parents', '--topo-order');
3055
3056     if (defined $lastcommit) {
3057         push @git_log_params, "$lastcommit..$self->{module}";
3058     } else {
3059         push @git_log_params, $self->{module};
3060     }
3061     # git-rev-list is the backend / plumbing version of git-log
3062     open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3063
3064     my @commits;
3065
3066     my %commit = ();
3067
3068     while ( <GITLOG> )
3069     {
3070         chomp;
3071         if (m/^commit\s+(.*)$/) {
3072             # on ^commit lines put the just seen commit in the stack
3073             # and prime things for the next one
3074             if (keys %commit) {
3075                 my %copy = %commit;
3076                 unshift @commits, \%copy;
3077                 %commit = ();
3078             }
3079             my @parents = split(m/\s+/, $1);
3080             $commit{hash} = shift @parents;
3081             $commit{parents} = \@parents;
3082         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3083             # on rfc822-like lines seen before we see any message,
3084             # lowercase the entry and put it in the hash as key-value
3085             $commit{lc($1)} = $2;
3086         } else {
3087             # message lines - skip initial empty line
3088             # and trim whitespace
3089             if (!exists($commit{message}) && m/^\s*$/) {
3090                 # define it to mark the end of headers
3091                 $commit{message} = '';
3092                 next;
3093             }
3094             s/^\s+//; s/\s+$//; # trim ws
3095             $commit{message} .= $_ . "\n";
3096         }
3097     }
3098     close GITLOG;
3099
3100     unshift @commits, \%commit if ( keys %commit );
3101
3102     # Now all the commits are in the @commits bucket
3103     # ordered by time DESC. for each commit that needs processing,
3104     # determine whether it's following the last head we've seen or if
3105     # it's on its own branch, grab a file list, and add whatever's changed
3106     # NOTE: $lastcommit refers to the last commit from previous run
3107     #       $lastpicked is the last commit we picked in this run
3108     my $lastpicked;
3109     my $head = {};
3110     if (defined $lastcommit) {
3111         $lastpicked = $lastcommit;
3112     }
3113
3114     my $committotal = scalar(@commits);
3115     my $commitcount = 0;
3116
3117     # Load the head table into $head (for cached lookups during the update process)
3118     foreach my $file ( @{$self->gethead()} )
3119     {
3120         $head->{$file->{name}} = $file;
3121     }
3122
3123     foreach my $commit ( @commits )
3124     {
3125         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3126         if (defined $lastpicked)
3127         {
3128             if (!in_array($lastpicked, @{$commit->{parents}}))
3129             {
3130                 # skip, we'll see this delta
3131                 # as part of a merge later
3132                 # warn "skipping off-track  $commit->{hash}\n";
3133                 next;
3134             } elsif (@{$commit->{parents}} > 1) {
3135                 # it is a merge commit, for each parent that is
3136                 # not $lastpicked, see if we can get a log
3137                 # from the merge-base to that parent to put it
3138                 # in the message as a merge summary.
3139                 my @parents = @{$commit->{parents}};
3140                 foreach my $parent (@parents) {
3141                     # git-merge-base can potentially (but rarely) throw
3142                     # several candidate merge bases. let's assume
3143                     # that the first one is the best one.
3144                     if ($parent eq $lastpicked) {
3145                         next;
3146                     }
3147                     my $base = eval {
3148                             safe_pipe_capture('git', 'merge-base',
3149                                                  $lastpicked, $parent);
3150                     };
3151                     # The two branches may not be related at all,
3152                     # in which case merge base simply fails to find
3153                     # any, but that's Ok.
3154                     next if ($@);
3155
3156                     chomp $base;
3157                     if ($base) {
3158                         my @merged;
3159                         # print "want to log between  $base $parent \n";
3160                         open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3161                           or die "Cannot call git-log: $!";
3162                         my $mergedhash;
3163                         while (<GITLOG>) {
3164                             chomp;
3165                             if (!defined $mergedhash) {
3166                                 if (m/^commit\s+(.+)$/) {
3167                                     $mergedhash = $1;
3168                                 } else {
3169                                     next;
3170                                 }
3171                             } else {
3172                                 # grab the first line that looks non-rfc822
3173                                 # aka has content after leading space
3174                                 if (m/^\s+(\S.*)$/) {
3175                                     my $title = $1;
3176                                     $title = substr($title,0,100); # truncate
3177                                     unshift @merged, "$mergedhash $title";
3178                                     undef $mergedhash;
3179                                 }
3180                             }
3181                         }
3182                         close GITLOG;
3183                         if (@merged) {
3184                             $commit->{mergemsg} = $commit->{message};
3185                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3186                             foreach my $summary (@merged) {
3187                                 $commit->{mergemsg} .= "\t$summary\n";
3188                             }
3189                             $commit->{mergemsg} .= "\n\n";
3190                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3191                         }
3192                     }
3193                 }
3194             }
3195         }
3196
3197         # convert the date to CVS-happy format
3198         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3199
3200         if ( defined ( $lastpicked ) )
3201         {
3202             my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3203             local ($/) = "\0";
3204             while ( <FILELIST> )
3205             {
3206                 chomp;
3207                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3208                 {
3209                     die("Couldn't process git-diff-tree line : $_");
3210                 }
3211                 my ($mode, $hash, $change) = ($1, $2, $3);
3212                 my $name = <FILELIST>;
3213                 chomp($name);
3214
3215                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3216
3217                 my $git_perms = "";
3218                 $git_perms .= "r" if ( $mode & 4 );
3219                 $git_perms .= "w" if ( $mode & 2 );
3220                 $git_perms .= "x" if ( $mode & 1 );
3221                 $git_perms = "rw" if ( $git_perms eq "" );
3222
3223                 if ( $change eq "D" )
3224                 {
3225                     #$log->debug("DELETE   $name");
3226                     $head->{$name} = {
3227                         name => $name,
3228                         revision => $head->{$name}{revision} + 1,
3229                         filehash => "deleted",
3230                         commithash => $commit->{hash},
3231                         modified => $commit->{date},
3232                         author => $commit->{author},
3233                         mode => $git_perms,
3234                     };
3235                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3236                 }
3237                 elsif ( $change eq "M" || $change eq "T" )
3238                 {
3239                     #$log->debug("MODIFIED $name");
3240                     $head->{$name} = {
3241                         name => $name,
3242                         revision => $head->{$name}{revision} + 1,
3243                         filehash => $hash,
3244                         commithash => $commit->{hash},
3245                         modified => $commit->{date},
3246                         author => $commit->{author},
3247                         mode => $git_perms,
3248                     };
3249                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3250                 }
3251                 elsif ( $change eq "A" )
3252                 {
3253                     #$log->debug("ADDED    $name");
3254                     $head->{$name} = {
3255                         name => $name,
3256                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3257                         filehash => $hash,
3258                         commithash => $commit->{hash},
3259                         modified => $commit->{date},
3260                         author => $commit->{author},
3261                         mode => $git_perms,
3262                     };
3263                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3264                 }
3265                 else
3266                 {
3267                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3268                     die;
3269                 }
3270             }
3271             close FILELIST;
3272         } else {
3273             # this is used to detect files removed from the repo
3274             my $seen_files = {};
3275
3276             my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3277             local $/ = "\0";
3278             while ( <FILELIST> )
3279             {
3280                 chomp;
3281                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3282                 {
3283                     die("Couldn't process git-ls-tree line : $_");
3284                 }
3285
3286                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3287
3288                 $seen_files->{$git_filename} = 1;
3289
3290                 my ( $oldhash, $oldrevision, $oldmode ) = (
3291                     $head->{$git_filename}{filehash},
3292                     $head->{$git_filename}{revision},
3293                     $head->{$git_filename}{mode}
3294                 );
3295
3296                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3297                 {
3298                     $git_perms = "";
3299                     $git_perms .= "r" if ( $1 & 4 );
3300                     $git_perms .= "w" if ( $1 & 2 );
3301                     $git_perms .= "x" if ( $1 & 1 );
3302                 } else {
3303                     $git_perms = "rw";
3304                 }
3305
3306                 # unless the file exists with the same hash, we need to update it ...
3307                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3308                 {
3309                     my $newrevision = ( $oldrevision or 0 ) + 1;
3310
3311                     $head->{$git_filename} = {
3312                         name => $git_filename,
3313                         revision => $newrevision,
3314                         filehash => $git_hash,
3315                         commithash => $commit->{hash},
3316                         modified => $commit->{date},
3317                         author => $commit->{author},
3318                         mode => $git_perms,
3319                     };
3320
3321
3322                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3323                 }
3324             }
3325             close FILELIST;
3326
3327             # Detect deleted files
3328             foreach my $file ( keys %$head )
3329             {
3330                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3331                 {
3332                     $head->{$file}{revision}++;
3333                     $head->{$file}{filehash} = "deleted";
3334                     $head->{$file}{commithash} = $commit->{hash};
3335                     $head->{$file}{modified} = $commit->{date};
3336                     $head->{$file}{author} = $commit->{author};
3337
3338                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3339                 }
3340             }
3341             # END : "Detect deleted files"
3342         }
3343
3344
3345         if (exists $commit->{mergemsg})
3346         {
3347             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3348         }
3349
3350         $lastpicked = $commit->{hash};
3351
3352         $self->_set_prop("last_commit", $commit->{hash});
3353     }
3354
3355     $self->delete_head();
3356     foreach my $file ( keys %$head )
3357     {
3358         $self->insert_head(
3359             $file,
3360             $head->{$file}{revision},
3361             $head->{$file}{filehash},
3362             $head->{$file}{commithash},
3363             $head->{$file}{modified},
3364             $head->{$file}{author},
3365             $head->{$file}{mode},
3366         );
3367     }
3368     # invalidate the gethead cache
3369     $self->{gethead_cache} = undef;
3370
3371
3372     # Ending exclusive lock here
3373     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3374 }
3375
3376 sub insert_rev
3377 {
3378     my $self = shift;
3379     my $name = shift;
3380     my $revision = shift;
3381     my $filehash = shift;
3382     my $commithash = shift;
3383     my $modified = shift;
3384     my $author = shift;
3385     my $mode = shift;
3386     my $tablename = $self->tablename("revision");
3387
3388     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3389     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3390 }
3391
3392 sub insert_mergelog
3393 {
3394     my $self = shift;
3395     my $key = shift;
3396     my $value = shift;
3397     my $tablename = $self->tablename("commitmsgs");
3398
3399     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3400     $insert_mergelog->execute($key, $value);
3401 }
3402
3403 sub delete_head
3404 {
3405     my $self = shift;
3406     my $tablename = $self->tablename("head");
3407
3408     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3409     $delete_head->execute();
3410 }
3411
3412 sub insert_head
3413 {
3414     my $self = shift;
3415     my $name = shift;
3416     my $revision = shift;
3417     my $filehash = shift;
3418     my $commithash = shift;
3419     my $modified = shift;
3420     my $author = shift;
3421     my $mode = shift;
3422     my $tablename = $self->tablename("head");
3423
3424     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3425     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3426 }
3427
3428 sub _headrev
3429 {
3430     my $self = shift;
3431     my $filename = shift;
3432     my $tablename = $self->tablename("head");
3433
3434     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3435     $db_query->execute($filename);
3436     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3437
3438     return ( $hash, $revision, $mode );
3439 }
3440
3441 sub _get_prop
3442 {
3443     my $self = shift;
3444     my $key = shift;
3445     my $tablename = $self->tablename("properties");
3446
3447     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3448     $db_query->execute($key);
3449     my ( $value ) = $db_query->fetchrow_array;
3450
3451     return $value;
3452 }
3453
3454 sub _set_prop
3455 {
3456     my $self = shift;
3457     my $key = shift;
3458     my $value = shift;
3459     my $tablename = $self->tablename("properties");
3460
3461     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3462     $db_query->execute($value, $key);
3463
3464     unless ( $db_query->rows )
3465     {
3466         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3467         $db_query->execute($key, $value);
3468     }
3469
3470     return $value;
3471 }
3472
3473 =head2 gethead
3474
3475 =cut
3476
3477 sub gethead
3478 {
3479     my $self = shift;
3480     my $tablename = $self->tablename("head");
3481
3482     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3483
3484     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3485     $db_query->execute();
3486
3487     my $tree = [];
3488     while ( my $file = $db_query->fetchrow_hashref )
3489     {
3490         push @$tree, $file;
3491     }
3492
3493     $self->{gethead_cache} = $tree;
3494
3495     return $tree;
3496 }
3497
3498 =head2 getlog
3499
3500 =cut
3501
3502 sub getlog
3503 {
3504     my $self = shift;
3505     my $filename = shift;
3506     my $tablename = $self->tablename("revision");
3507
3508     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3509     $db_query->execute($filename);
3510
3511     my $tree = [];
3512     while ( my $file = $db_query->fetchrow_hashref )
3513     {
3514         push @$tree, $file;
3515     }
3516
3517     return $tree;
3518 }
3519
3520 =head2 getmeta
3521
3522 This function takes a filename (with path) argument and returns a hashref of
3523 metadata for that file.
3524
3525 =cut
3526
3527 sub getmeta
3528 {
3529     my $self = shift;
3530     my $filename = shift;
3531     my $revision = shift;
3532     my $tablename_rev = $self->tablename("revision");
3533     my $tablename_head = $self->tablename("head");
3534
3535     my $db_query;
3536     if ( defined($revision) and $revision =~ /^\d+$/ )
3537     {
3538         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3539         $db_query->execute($filename, $revision);
3540     }
3541     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3542     {
3543         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3544         $db_query->execute($filename, $revision);
3545     } else {
3546         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3547         $db_query->execute($filename);
3548     }
3549
3550     return $db_query->fetchrow_hashref;
3551 }
3552
3553 =head2 commitmessage
3554
3555 this function takes a commithash and returns the commit message for that commit
3556
3557 =cut
3558 sub commitmessage
3559 {
3560     my $self = shift;
3561     my $commithash = shift;
3562     my $tablename = $self->tablename("commitmsgs");
3563
3564     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3565
3566     my $db_query;
3567     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3568     $db_query->execute($commithash);
3569
3570     my ( $message ) = $db_query->fetchrow_array;
3571
3572     if ( defined ( $message ) )
3573     {
3574         $message .= " " if ( $message =~ /\n$/ );
3575         return $message;
3576     }
3577
3578     my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3579     shift @lines while ( $lines[0] =~ /\S/ );
3580     $message = join("",@lines);
3581     $message .= " " if ( $message =~ /\n$/ );
3582     return $message;
3583 }
3584
3585 =head2 gethistory
3586
3587 This function takes a filename (with path) argument and returns an arrayofarrays
3588 containing revision,filehash,commithash ordered by revision descending
3589
3590 =cut
3591 sub gethistory
3592 {
3593     my $self = shift;
3594     my $filename = shift;
3595     my $tablename = $self->tablename("revision");
3596
3597     my $db_query;
3598     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3599     $db_query->execute($filename);
3600
3601     return $db_query->fetchall_arrayref;
3602 }
3603
3604 =head2 gethistorydense
3605
3606 This function takes a filename (with path) argument and returns an arrayofarrays
3607 containing revision,filehash,commithash ordered by revision descending.
3608
3609 This version of gethistory skips deleted entries -- so it is useful for annotate.
3610 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3611 and other git tools that depend on it.
3612
3613 =cut
3614 sub gethistorydense
3615 {
3616     my $self = shift;
3617     my $filename = shift;
3618     my $tablename = $self->tablename("revision");
3619
3620     my $db_query;
3621     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3622     $db_query->execute($filename);
3623
3624     return $db_query->fetchall_arrayref;
3625 }
3626
3627 =head2 in_array()
3628
3629 from Array::PAT - mimics the in_array() function
3630 found in PHP. Yuck but works for small arrays.
3631
3632 =cut
3633 sub in_array
3634 {
3635     my ($check, @array) = @_;
3636     my $retval = 0;
3637     foreach my $test (@array){
3638         if($check eq $test){
3639             $retval =  1;
3640         }
3641     }
3642     return $retval;
3643 }
3644
3645 =head2 safe_pipe_capture
3646
3647 an alternative to `command` that allows input to be passed as an array
3648 to work around shell problems with weird characters in arguments
3649
3650 =cut
3651 sub safe_pipe_capture {
3652
3653     my @output;
3654
3655     if (my $pid = open my $child, '-|') {
3656         @output = (<$child>);
3657         close $child or die join(' ',@_).": $! $?";
3658     } else {
3659         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3660     }
3661     return wantarray ? @output : join('',@output);
3662 }
3663
3664 =head2 mangle_dirname
3665
3666 create a string from a directory name that is suitable to use as
3667 part of a filename, mainly by converting all chars except \w.- to _
3668
3669 =cut
3670 sub mangle_dirname {
3671     my $dirname = shift;
3672     return unless defined $dirname;
3673
3674     $dirname =~ s/[^\w.-]/_/g;
3675
3676     return $dirname;
3677 }
3678
3679 =head2 mangle_tablename
3680
3681 create a string from a that is suitable to use as part of an SQL table
3682 name, mainly by converting all chars except \w to _
3683
3684 =cut
3685 sub mangle_tablename {
3686     my $tablename = shift;
3687     return unless defined $tablename;
3688
3689     $tablename =~ s/[^\w_]/_/g;
3690
3691     return $tablename;
3692 }
3693
3694 1;