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