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} . "/$checkout_path/\n";
 580     print "Clear-static-directory $checkout_path/\n";
 581     print $state->{CVSROOT} . "/$checkout_path/\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
 588     foreach my $git ( @{$updater->gethead} )
 589     {
 590         # Don't want to check out deleted files
 591         next if ( $git->{filehash} eq "deleted" );
 592
 593         ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
 594
 595         # modification time of this file
 596         print "Mod-time $git->{modified}\n";
 597
 598         # print some information to the client
 599         if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
 600         {
 601             print "M U $checkout_path/$git->{dir}$git->{name}\n";
 602         } else {
 603             print "M U $checkout_path/$git->{name}\n";
 604         }
 605
 606         if (length($git->{dir}) && $git->{dir} ne './' && !exists($seendirs{$git->{dir}})) {
 607
 608             # Eclipse seems to need the Clear-sticky command
 609             # to prepare the 'Entries' file for the new directory.
 610             print "Clear-sticky $module/$git->{dir}\n";
 611             print $state->{CVSROOT} . "/$module/$git->{dir}\n";
 612             print "Clear-static-directory $module/$git->{dir}\n";
 613             print $state->{CVSROOT} . "/$module/$git->{dir}\n";
 614             print "E cvs checkout: Updating /$module/$git->{dir}\n";
 615             $seendirs{$git->{dir}} = 1;
 616         }
 617
 618         # instruct client we're sending a file to put in this path
 619         print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
 620
 621         print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
 622
 623         # this is an "entries" line
 624         print "/$git->{name}/1.$git->{revision}///\n";
 625         # permissions
 626         print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
 627
 628         # transmit file
 629         transmitfile($git->{filehash});
 630     }
 631
 632     print "ok\n";
 633
 634     statecleanup();
 635 }
 636
 637 # update \n
 638 #     Response expected: yes. Actually do a cvs update command. This uses any
 639 #     previous Argument, Directory, Entry, or Modified requests, if they have
 640 #     been sent. The last Directory sent specifies the working directory at the
 641 #     time of the operation. The -I option is not used--files which the client
 642 #     can decide whether to ignore are not mentioned and the client sends the
 643 #     Questionable request for others.
 644 sub req_update
 645 {
 646     my ( $cmd, $data ) = @_;
 647
 648     $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
 649
 650     argsplit("update");
 651
 652     #
 653     # It may just be a client exploring the available heads/modukles
 654     # in that case, list them as top level directories and leave it
 655     # at that. Eclipse uses this technique to offer you a list of
 656     # projects (heads in this case) to checkout.
 657     #
 658     if ($state->{module} eq '') {
 659         print "E cvs update: Updating .\n";
 660         opendir HEADS, $state->{CVSROOT} . '/refs/heads';
 661         while (my $head = readdir(HEADS)) {
 662             if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
 663                 print "E cvs update: New directory `$head'\n";
 664             }
 665         }
 666         closedir HEADS;
 667         print "ok\n";
 668         return 1;
 669     }
 670
 671
 672     # Grab a handle to the SQLite db and do any necessary updates
 673     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 674
 675     $updater->update();
 676
 677     # if no files were specified, we need to work out what files we should be providing status on ...
 678     argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
 679
 680     #$log->debug("update state : " . Dumper($state));
 681
 682     # foreach file specified on the commandline ...
 683     foreach my $filename ( @{$state->{args}} )
 684     {
 685         $filename = filecleanup($filename);
 686
 687         # if we have a -C we should pretend we never saw modified stuff
 688         if ( exists ( $state->{opt}{C} ) )
 689         {
 690             delete $state->{entries}{$filename}{modified_hash};
 691             delete $state->{entries}{$filename}{modified_filename};
 692             $state->{entries}{$filename}{unchanged} = 1;
 693         }
 694
 695         my $meta;
 696         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
 697         {
 698             $meta = $updater->getmeta($filename, $1);
 699         } else {
 700             $meta = $updater->getmeta($filename);
 701         }
 702
 703         next unless ( $meta->{revision} );
 704
 705         my $oldmeta = $meta;
 706
 707         my $wrev = revparse($filename);
 708
 709         # If the working copy is an old revision, lets get that version too for comparison.
 710         if ( defined($wrev) and $wrev != $meta->{revision} )
 711         {
 712             $oldmeta = $updater->getmeta($filename, $wrev);
 713         }
 714
 715         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
 716
 717         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified _and_ the user hasn't specified -C
 718         next if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{unchanged} and not exists ( $state->{opt}{C} ) );
 719
 720         if ( $meta->{filehash} eq "deleted" )
 721         {
 722             my ( $filepart, $dirpart ) = filenamesplit($filename);
 723
 724             $log->info("Removing '$filename' from working copy (no longer in the repo)");
 725
 726             print "E cvs update: `$filename' is no longer in the repository\n";
 727             print "Removed $dirpart\n";
 728             print "$filepart\n";
 729         }
 730         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} ) or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
 731         {
 732             $log->info("Updating '$filename'");
 733             # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
 734             print "MT +updated\n";
 735             print "MT text U\n";
 736             print "MT fname $filename\n";
 737             print "MT newline\n";
 738             print "MT -updated\n";
 739
 740             my ( $filepart, $dirpart ) = filenamesplit($filename);
 741             $dirpart =~ s/^$state->{directory}//;
 742
 743             if ( defined ( $wrev ) )
 744             {
 745                 # instruct client we're sending a file to put in this path as a replacement
 746                 print "Update-existing $dirpart\n";
 747                 $log->debug("Updating existing file 'Update-existing $dirpart'");
 748             } else {
 749                 # instruct client we're sending a file to put in this path as a new file
 750                 print "Created $dirpart\n";
 751                 $log->debug("Creating new file 'Created $dirpart'");
 752             }
 753             print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 754
 755             # this is an "entries" line
 756             $log->debug("/$filepart/1.$meta->{revision}///");
 757             print "/$filepart/1.$meta->{revision}///\n";
 758
 759             # permissions
 760             $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
 761             print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
 762
 763             # transmit file
 764             transmitfile($meta->{filehash});
 765         } else {
 766             my ( $filepart, $dirpart ) = filenamesplit($meta->{name});
 767
 768             my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
 769
 770             chdir $dir;
 771             my $file_local = $filepart . ".mine";
 772             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
 773             my $file_old = $filepart . "." . $oldmeta->{revision};
 774             transmitfile($oldmeta->{filehash}, $file_old);
 775             my $file_new = $filepart . "." . $meta->{revision};
 776             transmitfile($meta->{filehash}, $file_new);
 777
 778             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
 779             $log->info("Merging $file_local, $file_old, $file_new");
 780
 781             $log->debug("Temporary directory for merge is $dir");
 782
 783             my $return = system("merge", $file_local, $file_old, $file_new);
 784             $return >>= 8;
 785
 786             if ( $return == 0 )
 787             {
 788                 $log->info("Merged successfully");
 789                 print "M M $filename\n";
 790                 $log->debug("Update-existing $dirpart");
 791                 print "Update-existing $dirpart\n";
 792                 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
 793                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 794                 $log->debug("/$filepart/1.$meta->{revision}///");
 795                 print "/$filepart/1.$meta->{revision}///\n";
 796             }
 797             elsif ( $return == 1 )
 798             {
 799                 $log->info("Merged with conflicts");
 800                 print "M C $filename\n";
 801                 print "Update-existing $dirpart\n";
 802                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 803                 print "/$filepart/1.$meta->{revision}/+//\n";
 804             }
 805             else
 806             {
 807                 $log->warn("Merge failed");
 808                 next;
 809             }
 810
 811             # permissions
 812             $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
 813             print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
 814
 815             # transmit file, format is single integer on a line by itself (file
 816             # size) followed by the file contents
 817             # TODO : we should copy files in blocks
 818             my $data = `cat $file_local`;
 819             $log->debug("File size : " . length($data));
 820             print length($data) . "\n";
 821             print $data;
 822
 823             chdir "/";
 824         }
 825
 826     }
 827
 828     print "ok\n";
 829 }
 830
 831 sub req_ci
 832 {
 833     my ( $cmd, $data ) = @_;
 834
 835     argsplit("ci");
 836
 837     #$log->debug("State : " . Dumper($state));
 838
 839     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
 840
 841     if ( -e $state->{CVSROOT} . "/index" )
 842     {
 843         print "error 1 Index already exists in git repo\n";
 844         exit;
 845     }
 846
 847     my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
 848     unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
 849     {
 850         print "error 1 Lock file '$lockfile' already exists, please try again\n";
 851         exit;
 852     }
 853
 854     # Grab a handle to the SQLite db and do any necessary updates
 855     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 856     $updater->update();
 857
 858     my $tmpdir = tempdir ( DIR => $TEMP_DIR );
 859     my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
 860     $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
 861
 862     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 863     $ENV{GIT_INDEX_FILE} = $file_index;
 864
 865     chdir $tmpdir;
 866
 867     # populate the temporary index based
 868     system("git-read-tree", $state->{module});
 869     unless ($? == 0)
 870     {
 871         die "Error running git-read-tree $state->{module} $file_index $!";
 872     }
 873     $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
 874
 875
 876     my @committedfiles = ();
 877
 878     # foreach file specified on the commandline ...
 879     foreach my $filename ( @{$state->{args}} )
 880     {
 881         $filename = filecleanup($filename);
 882
 883         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
 884
 885         my $meta = $updater->getmeta($filename);
 886
 887         my $wrev = revparse($filename);
 888
 889         my ( $filepart, $dirpart ) = filenamesplit($filename);
 890
 891         # do a checkout of the file if it part of this tree
 892         if ($wrev) {
 893             system('git-checkout-index', '-f', '-u', $filename);
 894             unless ($? == 0) {
 895                 die "Error running git-checkout-index -f -u $filename : $!";
 896             }
 897         }
 898
 899         my $addflag = 0;
 900         my $rmflag = 0;
 901         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
 902         $addflag = 1 unless ( -e $filename );
 903
 904         # Do up to date checking
 905         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
 906         {
 907             # fail everything if an up to date check fails
 908             print "error 1 Up to date check failed for $filename\n";
 909             close LOCKFILE;
 910             unlink($lockfile);
 911             chdir "/";
 912             exit;
 913         }
 914
 915         push @committedfiles, $filename;
 916         $log->info("Committing $filename");
 917
 918         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
 919
 920         unless ( $rmflag )
 921         {
 922             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
 923             rename $state->{entries}{$filename}{modified_filename},$filename;
 924
 925             # Calculate modes to remove
 926             my $invmode = "";
 927             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
 928
 929             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
 930             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
 931         }
 932
 933         if ( $rmflag )
 934         {
 935             $log->info("Removing file '$filename'");
 936             unlink($filename);
 937             system("git-update-index", "--remove", $filename);
 938         }
 939         elsif ( $addflag )
 940         {
 941             $log->info("Adding file '$filename'");
 942             system("git-update-index", "--add", $filename);
 943         } else {
 944             $log->info("Updating file '$filename'");
 945             system("git-update-index", $filename);
 946         }
 947     }
 948
 949     unless ( scalar(@committedfiles) > 0 )
 950     {
 951         print "E No files to commit\n";
 952         print "ok\n";
 953         close LOCKFILE;
 954         unlink($lockfile);
 955         chdir "/";
 956         return;
 957     }
 958
 959     my $treehash = `git-write-tree`;
 960     my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
 961     chomp $treehash;
 962     chomp $parenthash;
 963
 964     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
 965
 966     # write our commit message out if we have one ...
 967     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
 968     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
 969     print $msg_fh "\n\nvia git-CVS emulator\n";
 970     close $msg_fh;
 971
 972     my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
 973     $log->info("Commit hash : $commithash");
 974
 975     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
 976     {
 977         $log->warn("Commit failed (Invalid commit hash)");
 978         print "error 1 Commit failed (unknown reason)\n";
 979         close LOCKFILE;
 980         unlink($lockfile);
 981         chdir "/";
 982         exit;
 983     }
 984
 985     open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
 986     print FILE $commithash;
 987     close FILE;
 988
 989     $updater->update();
 990
 991     # foreach file specified on the commandline ...
 992     foreach my $filename ( @committedfiles )
 993     {
 994         $filename = filecleanup($filename);
 995
 996         my $meta = $updater->getmeta($filename);
 997
 998         my ( $filepart, $dirpart ) = filenamesplit($filename);
 999
1000         $log->debug("Checked-in $dirpart : $filename");
1001
1002         if ( $meta->{filehash} eq "deleted" )
1003         {
1004             print "Remove-entry $dirpart\n";
1005             print "$filename\n";
1006         } else {
1007             print "Checked-in $dirpart\n";
1008             print "$filename\n";
1009             print "/$filepart/1.$meta->{revision}///\n";
1010         }
1011     }
1012
1013     close LOCKFILE;
1014     unlink($lockfile);
1015     chdir "/";
1016
1017     print "ok\n";
1018 }
1019
1020 sub req_status
1021 {
1022     my ( $cmd, $data ) = @_;
1023
1024     argsplit("status");
1025
1026     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1027     #$log->debug("status state : " . Dumper($state));
1028
1029     # Grab a handle to the SQLite db and do any necessary updates
1030     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1031     $updater->update();
1032
1033     # if no files were specified, we need to work out what files we should be providing status on ...
1034     argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1035
1036     # foreach file specified on the commandline ...
1037     foreach my $filename ( @{$state->{args}} )
1038     {
1039         $filename = filecleanup($filename);
1040
1041         my $meta = $updater->getmeta($filename);
1042         my $oldmeta = $meta;
1043
1044         my $wrev = revparse($filename);
1045
1046         # If the working copy is an old revision, lets get that version too for comparison.
1047         if ( defined($wrev) and $wrev != $meta->{revision} )
1048         {
1049             $oldmeta = $updater->getmeta($filename, $wrev);
1050         }
1051
1052         # TODO : All possible statuses aren't yet implemented
1053         my $status;
1054         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1055         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1056                                     and
1057                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1058                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1059                                    );
1060
1061         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1062         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1063                                           and
1064                                           ( $state->{entries}{$filename}{unchanged}
1065                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1066                                         );
1067
1068         # Need checkout if it exists in the repo but doesn't have a working copy
1069         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1070
1071         # Locally modified if working copy and repo copy have the same revision but there are local changes
1072         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1073
1074         # Needs Merge if working copy revision is less than repo copy and there are local changes
1075         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1076
1077         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1078         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1079         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1080         $status ||= "File had conflicts on merge" if ( 0 );
1081
1082         $status ||= "Unknown";
1083
1084         print "M ===================================================================\n";
1085         print "M File: $filename\tStatus: $status\n";
1086         if ( defined($state->{entries}{$filename}{revision}) )
1087         {
1088             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1089         } else {
1090             print "M Working revision:\tNo entry for $filename\n";
1091         }
1092         if ( defined($meta->{revision}) )
1093         {
1094             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1095             print "M Sticky Tag:\t\t(none)\n";
1096             print "M Sticky Date:\t\t(none)\n";
1097             print "M Sticky Options:\t\t(none)\n";
1098         } else {
1099             print "M Repository revision:\tNo revision control file\n";
1100         }
1101         print "M\n";
1102     }
1103
1104     print "ok\n";
1105 }
1106
1107 sub req_diff
1108 {
1109     my ( $cmd, $data ) = @_;
1110
1111     argsplit("diff");
1112
1113     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1114     #$log->debug("status state : " . Dumper($state));
1115
1116     my ($revision1, $revision2);
1117     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1118     {
1119         $revision1 = $state->{opt}{r}[0];
1120         $revision2 = $state->{opt}{r}[1];
1121     } else {
1122         $revision1 = $state->{opt}{r};
1123     }
1124
1125     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1126     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1127
1128     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1129
1130     # Grab a handle to the SQLite db and do any necessary updates
1131     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1132     $updater->update();
1133
1134     # if no files were specified, we need to work out what files we should be providing status on ...
1135     argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1136
1137     # foreach file specified on the commandline ...
1138     foreach my $filename ( @{$state->{args}} )
1139     {
1140         $filename = filecleanup($filename);
1141
1142         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1143
1144         my $wrev = revparse($filename);
1145
1146         # We need _something_ to diff against
1147         next unless ( defined ( $wrev ) );
1148
1149         # if we have a -r switch, use it
1150         if ( defined ( $revision1 ) )
1151         {
1152             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1153             $meta1 = $updater->getmeta($filename, $revision1);
1154             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1155             {
1156                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1157                 next;
1158             }
1159             transmitfile($meta1->{filehash}, $file1);
1160         }
1161         # otherwise we just use the working copy revision
1162         else
1163         {
1164             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1165             $meta1 = $updater->getmeta($filename, $wrev);
1166             transmitfile($meta1->{filehash}, $file1);
1167         }
1168
1169         # if we have a second -r switch, use it too
1170         if ( defined ( $revision2 ) )
1171         {
1172             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1173             $meta2 = $updater->getmeta($filename, $revision2);
1174
1175             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1176             {
1177                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1178                 next;
1179             }
1180
1181             transmitfile($meta2->{filehash}, $file2);
1182         }
1183         # otherwise we just use the working copy
1184         else
1185         {
1186             $file2 = $state->{entries}{$filename}{modified_filename};
1187         }
1188
1189         # if we have been given -r, and we don't have a $file2 yet, lets get one
1190         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1191         {
1192             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1193             $meta2 = $updater->getmeta($filename, $wrev);
1194             transmitfile($meta2->{filehash}, $file2);
1195         }
1196
1197         # We need to have retrieved something useful
1198         next unless ( defined ( $meta1 ) );
1199
1200         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1201         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1202                   and
1203                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1204                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1205                   );
1206
1207         # Apparently we only show diffs for locally modified files
1208         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1209
1210         print "M Index: $filename\n";
1211         print "M ===================================================================\n";
1212         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1213         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1214         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1215         print "M diff ";
1216         foreach my $opt ( keys %{$state->{opt}} )
1217         {
1218             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1219             {
1220                 foreach my $value ( @{$state->{opt}{$opt}} )
1221                 {
1222                     print "-$opt $value ";
1223                 }
1224             } else {
1225                 print "-$opt ";
1226                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1227             }
1228         }
1229         print "$filename\n";
1230
1231         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1232
1233         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1234
1235         if ( exists $state->{opt}{u} )
1236         {
1237             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1238         } else {
1239             system("diff $file1 $file2 > $filediff");
1240         }
1241
1242         while ( <$fh> )
1243         {
1244             print "M $_";
1245         }
1246         close $fh;
1247     }
1248
1249     print "ok\n";
1250 }
1251
1252 sub req_log
1253 {
1254     my ( $cmd, $data ) = @_;
1255
1256     argsplit("log");
1257
1258     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1259     #$log->debug("log state : " . Dumper($state));
1260
1261     my ( $minrev, $maxrev );
1262     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1263     {
1264         my $control = $2;
1265         $minrev = $1;
1266         $maxrev = $3;
1267         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1268         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1269         $minrev++ if ( defined($minrev) and $control eq "::" );
1270     }
1271
1272     # Grab a handle to the SQLite db and do any necessary updates
1273     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1274     $updater->update();
1275
1276     # if no files were specified, we need to work out what files we should be providing status on ...
1277     argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1278
1279     # foreach file specified on the commandline ...
1280     foreach my $filename ( @{$state->{args}} )
1281     {
1282         $filename = filecleanup($filename);
1283
1284         my $headmeta = $updater->getmeta($filename);
1285
1286         my $revisions = $updater->getlog($filename);
1287         my $totalrevisions = scalar(@$revisions);
1288
1289         if ( defined ( $minrev ) )
1290         {
1291             $log->debug("Removing revisions less than $minrev");
1292             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1293             {
1294                 pop @$revisions;
1295             }
1296         }
1297         if ( defined ( $maxrev ) )
1298         {
1299             $log->debug("Removing revisions greater than $maxrev");
1300             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1301             {
1302                 shift @$revisions;
1303             }
1304         }
1305
1306         next unless ( scalar(@$revisions) );
1307
1308         print "M \n";
1309         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1310         print "M Working file: $filename\n";
1311         print "M head: 1.$headmeta->{revision}\n";
1312         print "M branch:\n";
1313         print "M locks: strict\n";
1314         print "M access list:\n";
1315         print "M symbolic names:\n";
1316         print "M keyword substitution: kv\n";
1317         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1318         print "M description:\n";
1319
1320         foreach my $revision ( @$revisions )
1321         {
1322             print "M ----------------------------\n";
1323             print "M revision 1.$revision->{revision}\n";
1324             # reformat the date for log output
1325             $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}) );
1326             $revision->{author} =~ s/\s+.*//;
1327             $revision->{author} =~ s/^(.{8}).*/$1/;
1328             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1329             my $commitmessage = $updater->commitmessage($revision->{commithash});
1330             $commitmessage =~ s/^/M /mg;
1331             print $commitmessage . "\n";
1332         }
1333         print "M =============================================================================\n";
1334     }
1335
1336     print "ok\n";
1337 }
1338
1339 sub req_annotate
1340 {
1341     my ( $cmd, $data ) = @_;
1342
1343     argsplit("annotate");
1344
1345     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1346     #$log->debug("status state : " . Dumper($state));
1347
1348     # Grab a handle to the SQLite db and do any necessary updates
1349     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1350     $updater->update();
1351
1352     # if no files were specified, we need to work out what files we should be providing annotate on ...
1353     argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1354
1355     # we'll need a temporary checkout dir
1356     my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1357     my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1358     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1359
1360     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1361     $ENV{GIT_INDEX_FILE} = $file_index;
1362
1363     chdir $tmpdir;
1364
1365     # foreach file specified on the commandline ...
1366     foreach my $filename ( @{$state->{args}} )
1367     {
1368         $filename = filecleanup($filename);
1369
1370         my $meta = $updater->getmeta($filename);
1371
1372         next unless ( $meta->{revision} );
1373
1374         # get all the commits that this file was in
1375         # in dense format -- aka skip dead revisions
1376         my $revisions   = $updater->gethistorydense($filename);
1377         my $lastseenin  = $revisions->[0][2];
1378
1379         # populate the temporary index based on the latest commit were we saw
1380         # the file -- but do it cheaply without checking out any files
1381         # TODO: if we got a revision from the client, use that instead
1382         # to look up the commithash in sqlite (still good to default to
1383         # the current head as we do now)
1384         system("git-read-tree", $lastseenin);
1385         unless ($? == 0)
1386         {
1387             die "Error running git-read-tree $lastseenin $file_index $!";
1388         }
1389         $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1390
1391         # do a checkout of the file
1392         system('git-checkout-index', '-f', '-u', $filename);
1393         unless ($? == 0) {
1394             die "Error running git-checkout-index -f -u $filename : $!";
1395         }
1396
1397         $log->info("Annotate $filename");
1398
1399         # Prepare a file with the commits from the linearized
1400         # history that annotate should know about. This prevents
1401         # git-jsannotate telling us about commits we are hiding
1402         # from the client.
1403
1404         open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1405         for (my $i=0; $i < @$revisions; $i++)
1406         {
1407             print ANNOTATEHINTS $revisions->[$i][2];
1408             if ($i+1 < @$revisions) { # have we got a parent?
1409                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1410             }
1411             print ANNOTATEHINTS "\n";
1412         }
1413
1414         print ANNOTATEHINTS "\n";
1415         close ANNOTATEHINTS;
1416
1417         my $annotatecmd = 'git-annotate';
1418         open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1419             or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1420         my $metadata = {};
1421         print "E Annotations for $filename\n";
1422         print "E ***************\n";
1423         while ( <ANNOTATE> )
1424         {
1425             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1426             {
1427                 my $commithash = $1;
1428                 my $data = $2;
1429                 unless ( defined ( $metadata->{$commithash} ) )
1430                 {
1431                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1432                     $metadata->{$commithash}{author} =~ s/\s+.*//;
1433                     $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1434                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1435                 }
1436                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1437                     $metadata->{$commithash}{revision},
1438                     $metadata->{$commithash}{author},
1439                     $metadata->{$commithash}{modified},
1440                     $data
1441                 );
1442             } else {
1443                 $log->warn("Error in annotate output! LINE: $_");
1444                 print "E Annotate error \n";
1445                 next;
1446             }
1447         }
1448         close ANNOTATE;
1449     }
1450
1451     # done; get out of the tempdir
1452     chdir "/";
1453
1454     print "ok\n";
1455
1456 }
1457
1458 # This method takes the state->{arguments} array and produces two new arrays.
1459 # The first is $state->{args} which is everything before the '--' argument, and
1460 # the second is $state->{files} which is everything after it.
1461 sub argsplit
1462 {
1463     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1464
1465     my $type = shift;
1466
1467     $state->{args} = [];
1468     $state->{files} = [];
1469     $state->{opt} = {};
1470
1471     if ( defined($type) )
1472     {
1473         my $opt = {};
1474         $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" );
1475         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1476         $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" );
1477         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1478         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1479         $opt = { k => 1, m => 1 } if ( $type eq "add" );
1480         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1481         $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" );
1482
1483
1484         while ( scalar ( @{$state->{arguments}} ) > 0 )
1485         {
1486             my $arg = shift @{$state->{arguments}};
1487
1488             next if ( $arg eq "--" );
1489             next unless ( $arg =~ /\S/ );
1490
1491             # if the argument looks like a switch
1492             if ( $arg =~ /^-(\w)(.*)/ )
1493             {
1494                 # if it's a switch that takes an argument
1495                 if ( $opt->{$1} )
1496                 {
1497                     # If this switch has already been provided
1498                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1499                     {
1500                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
1501                         if ( length($2) > 0 )
1502                         {
1503                             push @{$state->{opt}{$1}},$2;
1504                         } else {
1505                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1506                         }
1507                     } else {
1508                         # if there's extra data in the arg, use that as the argument for the switch
1509                         if ( length($2) > 0 )
1510                         {
1511                             $state->{opt}{$1} = $2;
1512                         } else {
1513                             $state->{opt}{$1} = shift @{$state->{arguments}};
1514                         }
1515                     }
1516                 } else {
1517                     $state->{opt}{$1} = undef;
1518                 }
1519             }
1520             else
1521             {
1522                 push @{$state->{args}}, $arg;
1523             }
1524         }
1525     }
1526     else
1527     {
1528         my $mode = 0;
1529
1530         foreach my $value ( @{$state->{arguments}} )
1531         {
1532             if ( $value eq "--" )
1533             {
1534                 $mode++;
1535                 next;
1536             }
1537             push @{$state->{args}}, $value if ( $mode == 0 );
1538             push @{$state->{files}}, $value if ( $mode == 1 );
1539         }
1540     }
1541 }
1542
1543 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1544 sub argsfromdir
1545 {
1546     my $updater = shift;
1547
1548     $state->{args} = [];
1549
1550     foreach my $file ( @{$updater->gethead} )
1551     {
1552         next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1553         next unless ( $file->{name} =~ s/^$state->{directory}// );
1554         push @{$state->{args}}, $file->{name};
1555     }
1556 }
1557
1558 # This method cleans up the $state variable after a command that uses arguments has run
1559 sub statecleanup
1560 {
1561     $state->{files} = [];
1562     $state->{args} = [];
1563     $state->{arguments} = [];
1564     $state->{entries} = {};
1565 }
1566
1567 sub revparse
1568 {
1569     my $filename = shift;
1570
1571     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1572
1573     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1574     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1575
1576     return undef;
1577 }
1578
1579 # This method takes a file hash and does a CVS "file transfer" which transmits the
1580 # size of the file, and then the file contents.
1581 # If a second argument $targetfile is given, the file is instead written out to
1582 # a file by the name of $targetfile
1583 sub transmitfile
1584 {
1585     my $filehash = shift;
1586     my $targetfile = shift;
1587
1588     if ( defined ( $filehash ) and $filehash eq "deleted" )
1589     {
1590         $log->warn("filehash is 'deleted'");
1591         return;
1592     }
1593
1594     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1595
1596     my $type = `git-cat-file -t $filehash`;
1597     chomp $type;
1598
1599     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1600
1601     my $size = `git-cat-file -s $filehash`;
1602     chomp $size;
1603
1604     $log->debug("transmitfile($filehash) size=$size, type=$type");
1605
1606     if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1607     {
1608         if ( defined ( $targetfile ) )
1609         {
1610             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1611             print NEWFILE $_ while ( <$fh> );
1612             close NEWFILE;
1613         } else {
1614             print "$size\n";
1615             print while ( <$fh> );
1616         }
1617         close $fh or die ("Couldn't close filehandle for transmitfile()");
1618     } else {
1619         die("Couldn't execute git-cat-file");
1620     }
1621 }
1622
1623 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1624 # refers to the directory porition and the file portion of the filename
1625 # respectively
1626 sub filenamesplit
1627 {
1628     my $filename = shift;
1629
1630     my ( $filepart, $dirpart ) = ( $filename, "." );
1631     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1632     $dirpart .= "/";
1633
1634     return ( $filepart, $dirpart );
1635 }
1636
1637 sub filecleanup
1638 {
1639     my $filename = shift;
1640
1641     return undef unless(defined($filename));
1642     if ( $filename =~ /^\// )
1643     {
1644         print "E absolute filenames '$filename' not supported by server\n";
1645         return undef;
1646     }
1647
1648     $filename =~ s/^\.\///g;
1649     $filename = $state->{directory} . $filename;
1650
1651     return $filename;
1652 }
1653
1654 package GITCVS::log;
1655
1656 ####
1657 #### Copyright The Open University UK - 2006.
1658 ####
1659 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
1660 ####          Martin Langhoff <martin@catalyst.net.nz>
1661 ####
1662 ####
1663
1664 use strict;
1665 use warnings;
1666
1667 =head1 NAME
1668
1669 GITCVS::log
1670
1671 =head1 DESCRIPTION
1672
1673 This module provides very crude logging with a similar interface to
1674 Log::Log4perl
1675
1676 =head1 METHODS
1677
1678 =cut
1679
1680 =head2 new
1681
1682 Creates a new log object, optionally you can specify a filename here to
1683 indicate the file to log to. If no log file is specified, you can specifiy one
1684 later with method setfile, or indicate you no longer want logging with method
1685 nofile.
1686
1687 Until one of these methods is called, all log calls will buffer messages ready
1688 to write out.
1689
1690 =cut
1691 sub new
1692 {
1693     my $class = shift;
1694     my $filename = shift;
1695
1696     my $self = {};
1697
1698     bless $self, $class;
1699
1700     if ( defined ( $filename ) )
1701     {
1702         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1703     }
1704
1705     return $self;
1706 }
1707
1708 =head2 setfile
1709
1710 This methods takes a filename, and attempts to open that file as the log file.
1711 If successful, all buffered data is written out to the file, and any further
1712 logging is written directly to the file.
1713
1714 =cut
1715 sub setfile
1716 {
1717     my $self = shift;
1718     my $filename = shift;
1719
1720     if ( defined ( $filename ) )
1721     {
1722         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1723     }
1724
1725     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1726
1727     while ( my $line = shift @{$self->{buffer}} )
1728     {
1729         print {$self->{fh}} $line;
1730     }
1731 }
1732
1733 =head2 nofile
1734
1735 This method indicates no logging is going to be used. It flushes any entries in
1736 the internal buffer, and sets a flag to ensure no further data is put there.
1737
1738 =cut
1739 sub nofile
1740 {
1741     my $self = shift;
1742
1743     $self->{nolog} = 1;
1744
1745     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1746
1747     $self->{buffer} = [];
1748 }
1749
1750 =head2 _logopen
1751
1752 Internal method. Returns true if the log file is open, false otherwise.
1753
1754 =cut
1755 sub _logopen
1756 {
1757     my $self = shift;
1758
1759     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1760     return 0;
1761 }
1762
1763 =head2 debug info warn fatal
1764
1765 These four methods are wrappers to _log. They provide the actual interface for
1766 logging data.
1767
1768 =cut
1769 sub debug { my $self = shift; $self->_log("debug", @_); }
1770 sub info  { my $self = shift; $self->_log("info" , @_); }
1771 sub warn  { my $self = shift; $self->_log("warn" , @_); }
1772 sub fatal { my $self = shift; $self->_log("fatal", @_); }
1773
1774 =head2 _log
1775
1776 This is an internal method called by the logging functions. It generates a
1777 timestamp and pushes the logged line either to file, or internal buffer.
1778
1779 =cut
1780 sub _log
1781 {
1782     my $self = shift;
1783     my $level = shift;
1784
1785     return if ( $self->{nolog} );
1786
1787     my @time = localtime;
1788     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1789         $time[5] + 1900,
1790         $time[4] + 1,
1791         $time[3],
1792         $time[2],
1793         $time[1],
1794         $time[0],
1795         uc $level,
1796     );
1797
1798     if ( $self->_logopen )
1799     {
1800         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1801     } else {
1802         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1803     }
1804 }
1805
1806 =head2 DESTROY
1807
1808 This method simply closes the file handle if one is open
1809
1810 =cut
1811 sub DESTROY
1812 {
1813     my $self = shift;
1814
1815     if ( $self->_logopen )
1816     {
1817         close $self->{fh};
1818     }
1819 }
1820
1821 package GITCVS::updater;
1822
1823 ####
1824 #### Copyright The Open University UK - 2006.
1825 ####
1826 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
1827 ####          Martin Langhoff <martin@catalyst.net.nz>
1828 ####
1829 ####
1830
1831 use strict;
1832 use warnings;
1833 use DBI;
1834
1835 =head1 METHODS
1836
1837 =cut
1838
1839 =head2 new
1840
1841 =cut
1842 sub new
1843 {
1844     my $class = shift;
1845     my $config = shift;
1846     my $module = shift;
1847     my $log = shift;
1848
1849     die "Need to specify a git repository" unless ( defined($config) and -d $config );
1850     die "Need to specify a module" unless ( defined($module) );
1851
1852     $class = ref($class) || $class;
1853
1854     my $self = {};
1855
1856     bless $self, $class;
1857
1858     $self->{dbdir} = $config . "/";
1859     die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
1860
1861     $self->{module} = $module;
1862     $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
1863
1864     $self->{git_path} = $config . "/";
1865
1866     $self->{log} = $log;
1867
1868     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
1869
1870     $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
1871
1872     $self->{tables} = {};
1873     foreach my $table ( $self->{dbh}->tables )
1874     {
1875         $table =~ s/^"//;
1876         $table =~ s/"$//;
1877         $self->{tables}{$table} = 1;
1878     }
1879
1880     # Construct the revision table if required
1881     unless ( $self->{tables}{revision} )
1882     {
1883         $self->{dbh}->do("
1884             CREATE TABLE revision (
1885                 name       TEXT NOT NULL,
1886                 revision   INTEGER NOT NULL,
1887                 filehash   TEXT NOT NULL,
1888                 commithash TEXT NOT NULL,
1889                 author     TEXT NOT NULL,
1890                 modified   TEXT NOT NULL,
1891                 mode       TEXT NOT NULL
1892             )
1893         ");
1894     }
1895
1896     # Construct the revision table if required
1897     unless ( $self->{tables}{head} )
1898     {
1899         $self->{dbh}->do("
1900             CREATE TABLE head (
1901                 name       TEXT NOT NULL,
1902                 revision   INTEGER NOT NULL,
1903                 filehash   TEXT NOT NULL,
1904                 commithash TEXT NOT NULL,
1905                 author     TEXT NOT NULL,
1906                 modified   TEXT NOT NULL,
1907                 mode       TEXT NOT NULL
1908             )
1909         ");
1910     }
1911
1912     # Construct the properties table if required
1913     unless ( $self->{tables}{properties} )
1914     {
1915         $self->{dbh}->do("
1916             CREATE TABLE properties (
1917                 key        TEXT NOT NULL PRIMARY KEY,
1918                 value      TEXT
1919             )
1920         ");
1921     }
1922
1923     # Construct the commitmsgs table if required
1924     unless ( $self->{tables}{commitmsgs} )
1925     {
1926         $self->{dbh}->do("
1927             CREATE TABLE commitmsgs (
1928                 key        TEXT NOT NULL PRIMARY KEY,
1929                 value      TEXT
1930             )
1931         ");
1932     }
1933
1934     return $self;
1935 }
1936
1937 =head2 update
1938
1939 =cut
1940 sub update
1941 {
1942     my $self = shift;
1943
1944     # first lets get the commit list
1945     $ENV{GIT_DIR} = $self->{git_path};
1946
1947     # prepare database queries
1948     my $db_insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1949     my $db_insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
1950     my $db_delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
1951     my $db_insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1952
1953     my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
1954     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
1955     {
1956         die("Invalid module '$self->{module}'");
1957     }
1958
1959
1960     my $git_log;
1961     my $lastcommit = $self->_get_prop("last_commit");
1962
1963     # Start exclusive lock here...
1964     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
1965
1966     # TODO: log processing is memory bound
1967     # if we can parse into a 2nd file that is in reverse order
1968     # we can probably do something really efficient
1969     my @git_log_params = ('--parents', '--topo-order');
1970
1971     if (defined $lastcommit) {
1972         push @git_log_params, "$lastcommit..$self->{module}";
1973     } else {
1974         push @git_log_params, $self->{module};
1975     }
1976     open(GITLOG, '-|', 'git-log', @git_log_params) or die "Cannot call git-log: $!";
1977
1978     my @commits;
1979
1980     my %commit = ();
1981
1982     while ( <GITLOG> )
1983     {
1984         chomp;
1985         if (m/^commit\s+(.*)$/) {
1986             # on ^commit lines put the just seen commit in the stack
1987             # and prime things for the next one
1988             if (keys %commit) {
1989                 my %copy = %commit;
1990                 unshift @commits, \%copy;
1991                 %commit = ();
1992             }
1993             my @parents = split(m/\s+/, $1);
1994             $commit{hash} = shift @parents;
1995             $commit{parents} = \@parents;
1996         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
1997             # on rfc822-like lines seen before we see any message,
1998             # lowercase the entry and put it in the hash as key-value
1999             $commit{lc($1)} = $2;
2000         } else {
2001             # message lines - skip initial empty line
2002             # and trim whitespace
2003             if (!exists($commit{message}) && m/^\s*$/) {
2004                 # define it to mark the end of headers
2005                 $commit{message} = '';
2006                 next;
2007             }
2008             s/^\s+//; s/\s+$//; # trim ws
2009             $commit{message} .= $_ . "\n";
2010         }
2011     }
2012     close GITLOG;
2013
2014     unshift @commits, \%commit if ( keys %commit );
2015
2016     # Now all the commits are in the @commits bucket
2017     # ordered by time DESC. for each commit that needs processing,
2018     # determine whether it's following the last head we've seen or if
2019     # it's on its own branch, grab a file list, and add whatever's changed
2020     # NOTE: $lastcommit refers to the last commit from previous run
2021     #       $lastpicked is the last commit we picked in this run
2022     my $lastpicked;
2023     my $head = {};
2024     if (defined $lastcommit) {
2025         $lastpicked = $lastcommit;
2026     }
2027
2028     my $committotal = scalar(@commits);
2029     my $commitcount = 0;
2030
2031     # Load the head table into $head (for cached lookups during the update process)
2032     foreach my $file ( @{$self->gethead()} )
2033     {
2034         $head->{$file->{name}} = $file;
2035     }
2036
2037     foreach my $commit ( @commits )
2038     {
2039         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2040         if (defined $lastpicked)
2041         {
2042             if (!in_array($lastpicked, @{$commit->{parents}}))
2043             {
2044                 # skip, we'll see this delta
2045                 # as part of a merge later
2046                 # warn "skipping off-track  $commit->{hash}\n";
2047                 next;
2048             } elsif (@{$commit->{parents}} > 1) {
2049                 # it is a merge commit, for each parent that is
2050                 # not $lastpicked, see if we can get a log
2051                 # from the merge-base to that parent to put it
2052                 # in the message as a merge summary.
2053                 my @parents = @{$commit->{parents}};
2054                 foreach my $parent (@parents) {
2055                     # git-merge-base can potentially (but rarely) throw
2056                     # several candidate merge bases. let's assume
2057                     # that the first one is the best one.
2058                     if ($parent eq $lastpicked) {
2059                         next;
2060                     }
2061                     open my $p, 'git-merge-base '. $lastpicked . ' '
2062                     . $parent . '|';
2063                     my @output = (<$p>);
2064                     close $p;
2065                     my $base = join('', @output);
2066                     chomp $base;
2067                     if ($base) {
2068                         my @merged;
2069                         # print "want to log between  $base $parent \n";
2070                         open(GITLOG, '-|', 'git-log', "$base..$parent")
2071                         or die "Cannot call git-log: $!";
2072                         my $mergedhash;
2073                         while (<GITLOG>) {
2074                             chomp;
2075                             if (!defined $mergedhash) {
2076                                 if (m/^commit\s+(.+)$/) {
2077                                     $mergedhash = $1;
2078                                 } else {
2079                                     next;
2080                                 }
2081                             } else {
2082                                 # grab the first line that looks non-rfc822
2083                                 # aka has content after leading space
2084                                 if (m/^\s+(\S.*)$/) {
2085                                     my $title = $1;
2086                                     $title = substr($title,0,100); # truncate
2087                                     unshift @merged, "$mergedhash $title";
2088                                     undef $mergedhash;
2089                                 }
2090                             }
2091                         }
2092                         close GITLOG;
2093                         if (@merged) {
2094                             $commit->{mergemsg} = $commit->{message};
2095                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2096                             foreach my $summary (@merged) {
2097                                 $commit->{mergemsg} .= "\t$summary\n";
2098                             }
2099                             $commit->{mergemsg} .= "\n\n";
2100                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2101                         }
2102                     }
2103                 }
2104             }
2105         }
2106
2107         # convert the date to CVS-happy format
2108         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2109
2110         if ( defined ( $lastpicked ) )
2111         {
2112             my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2113             while ( <FILELIST> )
2114             {
2115                 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 )
2116                 {
2117                     die("Couldn't process git-diff-tree line : $_");
2118                 }
2119
2120                 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2121
2122                 my $git_perms = "";
2123                 $git_perms .= "r" if ( $1 & 4 );
2124                 $git_perms .= "w" if ( $1 & 2 );
2125                 $git_perms .= "x" if ( $1 & 1 );
2126                 $git_perms = "rw" if ( $git_perms eq "" );
2127
2128                 if ( $3 eq "D" )
2129                 {
2130                     #$log->debug("DELETE   $4");
2131                     $head->{$4} = {
2132                         name => $4,
2133                         revision => $head->{$4}{revision} + 1,
2134                         filehash => "deleted",
2135                         commithash => $commit->{hash},
2136                         modified => $commit->{date},
2137                         author => $commit->{author},
2138                         mode => $git_perms,
2139                     };
2140                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2141                 }
2142                 elsif ( $3 eq "M" )
2143                 {
2144                     #$log->debug("MODIFIED $4");
2145                     $head->{$4} = {
2146                         name => $4,
2147                         revision => $head->{$4}{revision} + 1,
2148                         filehash => $2,
2149                         commithash => $commit->{hash},
2150                         modified => $commit->{date},
2151                         author => $commit->{author},
2152                         mode => $git_perms,
2153                     };
2154                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2155                 }
2156                 elsif ( $3 eq "A" )
2157                 {
2158                     #$log->debug("ADDED    $4");
2159                     $head->{$4} = {
2160                         name => $4,
2161                         revision => 1,
2162                         filehash => $2,
2163                         commithash => $commit->{hash},
2164                         modified => $commit->{date},
2165                         author => $commit->{author},
2166                         mode => $git_perms,
2167                     };
2168                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2169                 }
2170                 else
2171                 {
2172                     $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2173                     die;
2174                 }
2175             }
2176             close FILELIST;
2177         } else {
2178             # this is used to detect files removed from the repo
2179             my $seen_files = {};
2180
2181             my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2182             while ( <FILELIST> )
2183             {
2184                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2185                 {
2186                     die("Couldn't process git-ls-tree line : $_");
2187                 }
2188
2189                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2190
2191                 $seen_files->{$git_filename} = 1;
2192
2193                 my ( $oldhash, $oldrevision, $oldmode ) = (
2194                     $head->{$git_filename}{filehash},
2195                     $head->{$git_filename}{revision},
2196                     $head->{$git_filename}{mode}
2197                 );
2198
2199                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2200                 {
2201                     $git_perms = "";
2202                     $git_perms .= "r" if ( $1 & 4 );
2203                     $git_perms .= "w" if ( $1 & 2 );
2204                     $git_perms .= "x" if ( $1 & 1 );
2205                 } else {
2206                     $git_perms = "rw";
2207                 }
2208
2209                 # unless the file exists with the same hash, we need to update it ...
2210                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2211                 {
2212                     my $newrevision = ( $oldrevision or 0 ) + 1;
2213
2214                     $head->{$git_filename} = {
2215                         name => $git_filename,
2216                         revision => $newrevision,
2217                         filehash => $git_hash,
2218                         commithash => $commit->{hash},
2219                         modified => $commit->{date},
2220                         author => $commit->{author},
2221                         mode => $git_perms,
2222                     };
2223
2224
2225                     $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2226                 }
2227             }
2228             close FILELIST;
2229
2230             # Detect deleted files
2231             foreach my $file ( keys %$head )
2232             {
2233                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2234                 {
2235                     $head->{$file}{revision}++;
2236                     $head->{$file}{filehash} = "deleted";
2237                     $head->{$file}{commithash} = $commit->{hash};
2238                     $head->{$file}{modified} = $commit->{date};
2239                     $head->{$file}{author} = $commit->{author};
2240
2241                     $db_insert_rev->execute($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2242                 }
2243             }
2244             # END : "Detect deleted files"
2245         }
2246
2247
2248         if (exists $commit->{mergemsg})
2249         {
2250             $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2251         }
2252
2253         $lastpicked = $commit->{hash};
2254
2255         $self->_set_prop("last_commit", $commit->{hash});
2256     }
2257
2258     $db_delete_head->execute();
2259     foreach my $file ( keys %$head )
2260     {
2261         $db_insert_head->execute(
2262             $file,
2263             $head->{$file}{revision},
2264             $head->{$file}{filehash},
2265             $head->{$file}{commithash},
2266             $head->{$file}{modified},
2267             $head->{$file}{author},
2268             $head->{$file}{mode},
2269         );
2270     }
2271     # invalidate the gethead cache
2272     $self->{gethead_cache} = undef;
2273
2274
2275     # Ending exclusive lock here
2276     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2277 }
2278
2279 sub _headrev
2280 {
2281     my $self = shift;
2282     my $filename = shift;
2283
2284     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2285     $db_query->execute($filename);
2286     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2287
2288     return ( $hash, $revision, $mode );
2289 }
2290
2291 sub _get_prop
2292 {
2293     my $self = shift;
2294     my $key = shift;
2295
2296     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2297     $db_query->execute($key);
2298     my ( $value ) = $db_query->fetchrow_array;
2299
2300     return $value;
2301 }
2302
2303 sub _set_prop
2304 {
2305     my $self = shift;
2306     my $key = shift;
2307     my $value = shift;
2308
2309     my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2310     $db_query->execute($value, $key);
2311
2312     unless ( $db_query->rows )
2313     {
2314         $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2315         $db_query->execute($key, $value);
2316     }
2317
2318     return $value;
2319 }
2320
2321 =head2 gethead
2322
2323 =cut
2324
2325 sub gethead
2326 {
2327     my $self = shift;
2328
2329     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2330
2331     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head",{},1);
2332     $db_query->execute();
2333
2334     my $tree = [];
2335     while ( my $file = $db_query->fetchrow_hashref )
2336     {
2337         push @$tree, $file;
2338     }
2339
2340     $self->{gethead_cache} = $tree;
2341
2342     return $tree;
2343 }
2344
2345 =head2 getlog
2346
2347 =cut
2348
2349 sub getlog
2350 {
2351     my $self = shift;
2352     my $filename = shift;
2353
2354     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2355     $db_query->execute($filename);
2356
2357     my $tree = [];
2358     while ( my $file = $db_query->fetchrow_hashref )
2359     {
2360         push @$tree, $file;
2361     }
2362
2363     return $tree;
2364 }
2365
2366 =head2 getmeta
2367
2368 This function takes a filename (with path) argument and returns a hashref of
2369 metadata for that file.
2370
2371 =cut
2372
2373 sub getmeta
2374 {
2375     my $self = shift;
2376     my $filename = shift;
2377     my $revision = shift;
2378
2379     my $db_query;
2380     if ( defined($revision) and $revision =~ /^\d+$/ )
2381     {
2382         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2383         $db_query->execute($filename, $revision);
2384     }
2385     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2386     {
2387         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2388         $db_query->execute($filename, $revision);
2389     } else {
2390         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2391         $db_query->execute($filename);
2392     }
2393
2394     return $db_query->fetchrow_hashref;
2395 }
2396
2397 =head2 commitmessage
2398
2399 this function takes a commithash and returns the commit message for that commit
2400
2401 =cut
2402 sub commitmessage
2403 {
2404     my $self = shift;
2405     my $commithash = shift;
2406
2407     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2408
2409     my $db_query;
2410     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2411     $db_query->execute($commithash);
2412
2413     my ( $message ) = $db_query->fetchrow_array;
2414
2415     if ( defined ( $message ) )
2416     {
2417         $message .= " " if ( $message =~ /\n$/ );
2418         return $message;
2419     }
2420
2421     my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2422     shift @lines while ( $lines[0] =~ /\S/ );
2423     $message = join("",@lines);
2424     $message .= " " if ( $message =~ /\n$/ );
2425     return $message;
2426 }
2427
2428 =head2 gethistory
2429
2430 This function takes a filename (with path) argument and returns an arrayofarrays
2431 containing revision,filehash,commithash ordered by revision descending
2432
2433 =cut
2434 sub gethistory
2435 {
2436     my $self = shift;
2437     my $filename = shift;
2438
2439     my $db_query;
2440     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2441     $db_query->execute($filename);
2442
2443     return $db_query->fetchall_arrayref;
2444 }
2445
2446 =head2 gethistorydense
2447
2448 This function takes a filename (with path) argument and returns an arrayofarrays
2449 containing revision,filehash,commithash ordered by revision descending.
2450
2451 This version of gethistory skips deleted entries -- so it is useful for annotate.
2452 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2453 and other git tools that depend on it.
2454
2455 =cut
2456 sub gethistorydense
2457 {
2458     my $self = shift;
2459     my $filename = shift;
2460
2461     my $db_query;
2462     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2463     $db_query->execute($filename);
2464
2465     return $db_query->fetchall_arrayref;
2466 }
2467
2468 =head2 in_array()
2469
2470 from Array::PAT - mimics the in_array() function
2471 found in PHP. Yuck but works for small arrays.
2472
2473 =cut
2474 sub in_array
2475 {
2476     my ($check, @array) = @_;
2477     my $retval = 0;
2478     foreach my $test (@array){
2479         if($check eq $test){
2480             $retval =  1;
2481         }
2482     }
2483     return $retval;
2484 }
2485
2486 =head2 safe_pipe_capture
2487
2488 an alterative to `command` that allows input to be passed as an array
2489 to work around shell problems with weird characters in arguments
2490
2491 =cut
2492 sub safe_pipe_capture {
2493
2494     my @output;
2495
2496     if (my $pid = open my $child, '-|') {
2497         @output = (<$child>);
2498         close $child or die join(' ',@_).": $! $?";
2499     } else {
2500         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2501     }
2502     return wantarray ? @output : join('',@output);
2503 }
2504
2505
2506 1;