git.oblomov.eu Git - git/blob - git-cvsserver.perl

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