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