git-cvsserver.perl

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