git-cvsserver.perl

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