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