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

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