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