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