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