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