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