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