git-cvsserver.perl

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