git.oblomov.eu Git - git/blob - git-cvsserver.perl

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