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