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