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