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