git-cvsserver.perl

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