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