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