Andrew's git - gitweb.git/blob - git-cvsserver.perl

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