1#!/usr/local/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@laptop.org> 12#### 13#### 14#### Released under the GNU Public License, version 2. 15#### 16#### 17 18use 5.008; 19use strict; 20use warnings; 21use bytes; 22 23use Fcntl; 24use File::Temp qw/tempdir tempfile/; 25use File::Path qw/rmtree/; 26use File::Basename; 27use Getopt::Long qw(:config require_order no_ignore_case); 28 29my $VERSION = '@@GIT_VERSION@@'; 30 31my $log = GITCVS::log->new(); 32my $cfg; 33 34my $DATE_LIST = { 35 Jan => "01", 36 Feb => "02", 37 Mar => "03", 38 Apr => "04", 39 May => "05", 40 Jun => "06", 41 Jul => "07", 42 Aug => "08", 43 Sep => "09", 44 Oct => "10", 45 Nov => "11", 46 Dec => "12", 47}; 48 49# Enable autoflush for STDOUT (otherwise the whole thing falls apart) 50$| = 1; 51 52#### Definition and mappings of functions #### 53 54# NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented 55# requests, this list is incomplete. It is missing many rarer/optional 56# requests. Perhaps some clients require a claim of support for 57# these specific requests for main functionality to work? 58my $methods = { 59 'Root' => \&req_Root, 60 'Valid-responses' => \&req_Validresponses, 61 'valid-requests' => \&req_validrequests, 62 'Directory' => \&req_Directory, 63 'Sticky' => \&req_Sticky, 64 'Entry' => \&req_Entry, 65 'Modified' => \&req_Modified, 66 'Unchanged' => \&req_Unchanged, 67 'Questionable' => \&req_Questionable, 68 'Argument' => \&req_Argument, 69 'Argumentx' => \&req_Argument, 70 'expand-modules' => \&req_expandmodules, 71 'add' => \&req_add, 72 'remove' => \&req_remove, 73 'co' => \&req_co, 74 'update' => \&req_update, 75 'ci' => \&req_ci, 76 'diff' => \&req_diff, 77 'log' => \&req_log, 78 'rlog' => \&req_log, 79 'tag' => \&req_CATCHALL, 80 'status' => \&req_status, 81 'admin' => \&req_CATCHALL, 82 'history' => \&req_CATCHALL, 83 'watchers' => \&req_EMPTY, 84 'editors' => \&req_EMPTY, 85 'noop' => \&req_EMPTY, 86 'annotate' => \&req_annotate, 87 'Global_option' => \&req_Globaloption, 88}; 89 90############################################## 91 92 93# $state holds all the bits of information the clients sends us that could 94# potentially be useful when it comes to actually _doing_ something. 95my $state = { prependdir => '' }; 96 97# Work is for managing temporary working directory 98my $work = 99 { 100 state => undef, # undef, 1 (empty), 2 (with stuff) 101 workDir => undef, 102 index => undef, 103 emptyDir => undef, 104 tmpDir => undef 105 }; 106 107$log->info("--------------- STARTING -----------------"); 108 109my $usage = 110 "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n". 111 " --base-path <path> : Prepend to requested CVSROOT\n". 112 " Can be read from GIT_CVSSERVER_BASE_PATH\n". 113 " --strict-paths : Don't allow recursing into subdirectories\n". 114 " --export-all : Don't check for gitcvs.enabled in config\n". 115 " --version, -V : Print version information and exit\n". 116 " -h, -H : Print usage information and exit\n". 117 "\n". 118 "<directory> ... is a list of allowed directories. If no directories\n". 119 "are given, all are allowed. This is an additional restriction, gitcvs\n". 120 "access still needs to be enabled by the gitcvs.enabled config option.\n". 121 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n"; 122 123my @opts = ( 'h|H', 'version|V', 124 'base-path=s', 'strict-paths', 'export-all' ); 125GetOptions( $state, @opts ) 126 or die $usage; 127 128if ($state->{version}) { 129 print "git-cvsserver version $VERSION\n"; 130 exit; 131} 132if ($state->{help}) { 133 print $usage; 134 exit; 135} 136 137my $TEMP_DIR = tempdir( CLEANUP => 1 ); 138$log->debug("Temporary directory is '$TEMP_DIR'"); 139 140$state->{method} = 'ext'; 141if (@ARGV) { 142 if ($ARGV[0] eq 'pserver') { 143 $state->{method} = 'pserver'; 144 shift @ARGV; 145 } elsif ($ARGV[0] eq 'server') { 146 shift @ARGV; 147 } 148} 149 150# everything else is a directory 151$state->{allowed_roots} = [ @ARGV ]; 152 153# don't export the whole system unless the users requests it 154if ($state->{'export-all'} && !@{$state->{allowed_roots}}) { 155 die "--export-all can only be used together with an explicit whitelist\n"; 156} 157 158# Environment handling for running under git-shell 159if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) { 160 if ($state->{'base-path'}) { 161 die "Cannot specify base path both ways.\n"; 162 } 163 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH}; 164 $state->{'base-path'} = $base_path; 165 $log->debug("Picked up base path '$base_path' from environment.\n"); 166} 167if (exists $ENV{GIT_CVSSERVER_ROOT}) { 168 if (@{$state->{allowed_roots}}) { 169 die "Cannot specify roots both ways: @ARGV\n"; 170 } 171 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT}; 172 $state->{allowed_roots} = [ $allowed_root ]; 173 $log->debug("Picked up allowed root '$allowed_root' from environment.\n"); 174} 175 176# if we are called with a pserver argument, 177# deal with the authentication cat before entering the 178# main loop 179if ($state->{method} eq 'pserver') { 180 my $line = <STDIN>; chomp $line; 181 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) { 182 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n"; 183 } 184 my $request = $1; 185 $line = <STDIN>; chomp $line; 186 unless (req_Root('root', $line)) { # reuse Root 187 print "E Invalid root $line \n"; 188 exit 1; 189 } 190 $line = <STDIN>; chomp $line; 191 my $user = $line; 192 $line = <STDIN>; chomp $line; 193 my $password = $line; 194 195 if ($user eq 'anonymous') { 196 # "A" will be 1 byte, use length instead in case the 197 # encryption method ever changes (yeah, right!) 198 if (length($password) > 1 ) { 199 print "E Don't supply a password for the `anonymous' user\n"; 200 print "I HATE YOU\n"; 201 exit 1; 202 } 203 204 # Fall through to LOVE 205 } else { 206 # Trying to authenticate a user 207 if (not exists $cfg->{gitcvs}->{authdb}) { 208 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n"; 209 print "I HATE YOU\n"; 210 exit 1; 211 } 212 213 my $authdb = $cfg->{gitcvs}->{authdb}; 214 215 unless (-e $authdb) { 216 print "E The authentication database specified in [gitcvs.authdb] does not exist\n"; 217 print "I HATE YOU\n"; 218 exit 1; 219 } 220 221 my $auth_ok; 222 open my $passwd, "<", $authdb or die $!; 223 while (<$passwd>) { 224 if (m{^\Q$user\E:(.*)}) { 225 my $hash = crypt(descramble($password), $1); 226 if (defined $hash and $hash eq $1) { 227 $auth_ok = 1; 228 } 229 } 230 } 231 close $passwd; 232 233 unless ($auth_ok) { 234 print "I HATE YOU\n"; 235 exit 1; 236 } 237 238 # Fall through to LOVE 239 } 240 241 # For checking whether the user is anonymous on commit 242 $state->{user} = $user; 243 244 $line = <STDIN>; chomp $line; 245 unless ($line eq "END $request REQUEST") { 246 die "E Do not understand $line -- expecting END $request REQUEST\n"; 247 } 248 print "I LOVE YOU\n"; 249 exit if $request eq 'VERIFICATION'; # cvs login 250 # and now back to our regular programme... 251} 252 253# Keep going until the client closes the connection 254while (<STDIN>) 255{ 256 chomp; 257 258 # Check to see if we've seen this method, and call appropriate function. 259 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) ) 260 { 261 # use the $methods hash to call the appropriate sub for this command 262 #$log->info("Method : $1"); 263 &{$methods->{$1}}($1,$2); 264 } else { 265 # log fatal because we don't understand this function. If this happens 266 # we're fairly screwed because we don't know if the client is expecting 267 # a response. If it is, the client will hang, we'll hang, and the whole 268 # thing will be custard. 269 $log->fatal("Don't understand command $_\n"); 270 die("Unknown command $_"); 271 } 272} 273 274$log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]); 275$log->info("--------------- FINISH -----------------"); 276 277chdir '/'; 278exit 0; 279 280# Magic catchall method. 281# This is the method that will handle all commands we haven't yet 282# implemented. It simply sends a warning to the log file indicating a 283# command that hasn't been implemented has been invoked. 284sub req_CATCHALL 285{ 286 my ( $cmd, $data ) = @_; 287 $log->warn("Unhandled command : req_$cmd : $data"); 288} 289 290# This method invariably succeeds with an empty response. 291sub req_EMPTY 292{ 293 print "ok\n"; 294} 295 296# Root pathname \n 297# Response expected: no. Tell the server which CVSROOT to use. Note that 298# pathname is a local directory and not a fully qualified CVSROOT variable. 299# pathname must already exist; if creating a new root, use the init 300# request, not Root. pathname does not include the hostname of the server, 301# how to access the server, etc.; by the time the CVS protocol is in use, 302# connection, authentication, etc., are already taken care of. The Root 303# request must be sent only once, and it must be sent before any requests 304# other than Valid-responses, valid-requests, UseUnchanged, Set or init. 305sub req_Root 306{ 307 my ( $cmd, $data ) = @_; 308 $log->debug("req_Root : $data"); 309 310 unless ($data =~ m#^/#) { 311 print "error 1 Root must be an absolute pathname\n"; 312 return 0; 313 } 314 315 my $cvsroot = $state->{'base-path'} || ''; 316 $cvsroot =~ s#/+$##; 317 $cvsroot .= $data; 318 319 if ($state->{CVSROOT} 320 && ($state->{CVSROOT} ne $cvsroot)) { 321 print "error 1 Conflicting roots specified\n"; 322 return 0; 323 } 324 325 $state->{CVSROOT} = $cvsroot; 326 327 $ENV{GIT_DIR} = $state->{CVSROOT} . "/"; 328 329 if (@{$state->{allowed_roots}}) { 330 my $allowed = 0; 331 foreach my $dir (@{$state->{allowed_roots}}) { 332 next unless $dir =~ m#^/#; 333 $dir =~ s#/+$##; 334 if ($state->{'strict-paths'}) { 335 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) { 336 $allowed = 1; 337 last; 338 } 339 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) { 340 $allowed = 1; 341 last; 342 } 343 } 344 345 unless ($allowed) { 346 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n"; 347 print "E \n"; 348 print "error 1 $ENV{GIT_DIR} is not a valid repository\n"; 349 return 0; 350 } 351 } 352 353 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') { 354 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n"; 355 print "E \n"; 356 print "error 1 $ENV{GIT_DIR} is not a valid repository\n"; 357 return 0; 358 } 359 360 my @gitvars = safe_pipe_capture(qw(git config -l)); 361 if ($?) { 362 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n"; 363 print "E \n"; 364 print "error 1 - problem executing git-config\n"; 365 return 0; 366 } 367 foreach my $line ( @gitvars ) 368 { 369 next unless ( $line =~ /^(gitcvs|extensions)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ ); 370 unless ($2) { 371 $cfg->{$1}{$3} = $4; 372 } else { 373 $cfg->{$1}{$2}{$3} = $4; 374 } 375 } 376 377 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled} 378 || $cfg->{gitcvs}{enabled}); 379 unless ($state->{'export-all'} || 380 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) { 381 print "E GITCVS emulation needs to be enabled on this repo\n"; 382 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n"; 383 print "E \n"; 384 print "error 1 GITCVS emulation disabled\n"; 385 return 0; 386 } 387 388 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile}; 389 if ( $logfile ) 390 { 391 $log->setfile($logfile); 392 } else { 393 $log->nofile(); 394 } 395 396 $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20; 397 $state->{hexsz} = $state->{rawsz} * 2; 398 399 return 1; 400} 401 402# Global_option option \n 403# Response expected: no. Transmit one of the global options `-q', `-Q', 404# `-l', `-t', `-r', or `-n'. option must be one of those strings, no 405# variations (such as combining of options) are allowed. For graceful 406# handling of valid-requests, it is probably better to make new global 407# options separate requests, rather than trying to add them to this 408# request. 409sub req_Globaloption 410{ 411 my ( $cmd, $data ) = @_; 412 $log->debug("req_Globaloption : $data"); 413 $state->{globaloptions}{$data} = 1; 414} 415 416# Valid-responses request-list \n 417# Response expected: no. Tell the server what responses the client will 418# accept. request-list is a space separated list of tokens. 419sub req_Validresponses 420{ 421 my ( $cmd, $data ) = @_; 422 $log->debug("req_Validresponses : $data"); 423 424 # TODO : re-enable this, currently it's not particularly useful 425 #$state->{validresponses} = [ split /\s+/, $data ]; 426} 427 428# valid-requests \n 429# Response expected: yes. Ask the server to send back a Valid-requests 430# response. 431sub req_validrequests 432{ 433 my ( $cmd, $data ) = @_; 434 435 $log->debug("req_validrequests"); 436 437 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods)); 438 $log->debug("SEND : ok"); 439 440 print "Valid-requests " . join(" ",sort keys %$methods) . "\n"; 441 print "ok\n"; 442} 443 444# Directory local-directory \n 445# Additional data: repository \n. Response expected: no. Tell the server 446# what directory to use. The repository should be a directory name from a 447# previous server response. Note that this both gives a default for Entry 448# and Modified and also for ci and the other commands; normal usage is to 449# send Directory for each directory in which there will be an Entry or 450# Modified, and then a final Directory for the original directory, then the 451# command. The local-directory is relative to the top level at which the 452# command is occurring (i.e. the last Directory which is sent before the 453# command); to indicate that top level, `.' should be sent for 454# local-directory. 455sub req_Directory 456{ 457 my ( $cmd, $data ) = @_; 458 459 my $repository = <STDIN>; 460 chomp $repository; 461 462 463 $state->{localdir} = $data; 464 $state->{repository} = $repository; 465 $state->{path} = $repository; 466 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///; 467 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//); 468 $state->{path} .= "/" if ( $state->{path} =~ /\S/ ); 469 470 $state->{directory} = $state->{localdir}; 471 $state->{directory} = "" if ( $state->{directory} eq "." ); 472 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ ); 473 474 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ ) 475 { 476 $log->info("Setting prepend to '$state->{path}'"); 477 $state->{prependdir} = $state->{path}; 478 my %entries; 479 foreach my $entry ( keys %{$state->{entries}} ) 480 { 481 $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry}; 482 } 483 $state->{entries}=\%entries; 484 485 my %dirMap; 486 foreach my $dir ( keys %{$state->{dirMap}} ) 487 { 488 $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir}; 489 } 490 $state->{dirMap}=\%dirMap; 491 } 492 493 if ( defined ( $state->{prependdir} ) ) 494 { 495 $log->debug("Prepending '$state->{prependdir}' to state|directory"); 496 $state->{directory} = $state->{prependdir} . $state->{directory} 497 } 498 499 if ( ! defined($state->{dirMap}{$state->{directory}}) ) 500 { 501 $state->{dirMap}{$state->{directory}} = 502 { 503 'names' => {} 504 #'tagspec' => undef 505 }; 506 } 507 508 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}"); 509} 510 511# Sticky tagspec \n 512# Response expected: no. Tell the server that the directory most 513# recently specified with Directory has a sticky tag or date 514# tagspec. The first character of tagspec is T for a tag, D for 515# a date, or some other character supplied by a Set-sticky 516# response from a previous request to the server. The remainder 517# of tagspec contains the actual tag or date, again as supplied 518# by Set-sticky. 519# The server should remember Static-directory and Sticky requests 520# for a particular directory; the client need not resend them each 521# time it sends a Directory request for a given directory. However, 522# the server is not obliged to remember them beyond the context 523# of a single command. 524sub req_Sticky 525{ 526 my ( $cmd, $tagspec ) = @_; 527 528 my ( $stickyInfo ); 529 if($tagspec eq "") 530 { 531 # nothing 532 } 533 elsif($tagspec=~/^T([^ ]+)\s*$/) 534 { 535 $stickyInfo = { 'tag' => $1 }; 536 } 537 elsif($tagspec=~/^D([0-9.]+)\s*$/) 538 { 539 $stickyInfo= { 'date' => $1 }; 540 } 541 else 542 { 543 die "Unknown tag_or_date format\n"; 544 } 545 $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo; 546 547 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}" 548 . " path=$state->{path} directory=$state->{directory}" 549 . " module=$state->{module}"); 550} 551 552# Entry entry-line \n 553# Response expected: no. Tell the server what version of a file is on the 554# local machine. The name in entry-line is a name relative to the directory 555# most recently specified with Directory. If the user is operating on only 556# some files in a directory, Entry requests for only those files need be 557# included. If an Entry request is sent without Modified, Is-modified, or 558# Unchanged, it means the file is lost (does not exist in the working 559# directory). If both Entry and one of Modified, Is-modified, or Unchanged 560# are sent for the same file, Entry must be sent first. For a given file, 561# one can send Modified, Is-modified, or Unchanged, but not more than one 562# of these three. 563sub req_Entry 564{ 565 my ( $cmd, $data ) = @_; 566 567 #$log->debug("req_Entry : $data"); 568 569 my @data = split(/\//, $data, -1); 570 571 $state->{entries}{$state->{directory}.$data[1]} = { 572 revision => $data[2], 573 conflict => $data[3], 574 options => $data[4], 575 tag_or_date => $data[5], 576 }; 577 578 $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F'; 579 580 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'"); 581} 582 583# Questionable filename \n 584# Response expected: no. Additional data: no. Tell the server to check 585# whether filename should be ignored, and if not, next time the server 586# sends responses, send (in a M response) `?' followed by the directory and 587# filename. filename must not contain `/'; it needs to be a file in the 588# directory named by the most recent Directory request. 589sub req_Questionable 590{ 591 my ( $cmd, $data ) = @_; 592 593 $log->debug("req_Questionable : $data"); 594 $state->{entries}{$state->{directory}.$data}{questionable} = 1; 595} 596 597# add \n 598# Response expected: yes. Add a file or directory. This uses any previous 599# Argument, Directory, Entry, or Modified requests, if they have been sent. 600# The last Directory sent specifies the working directory at the time of 601# the operation. To add a directory, send the directory to be added using 602# Directory and Argument requests. 603sub req_add 604{ 605 my ( $cmd, $data ) = @_; 606 607 argsplit("add"); 608 609 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 610 $updater->update(); 611 612 my $addcount = 0; 613 614 foreach my $filename ( @{$state->{args}} ) 615 { 616 $filename = filecleanup($filename); 617 618 # no -r, -A, or -D with add 619 my $stickyInfo = resolveStickyInfo($filename); 620 621 my $meta = $updater->getmeta($filename,$stickyInfo); 622 my $wrev = revparse($filename); 623 624 if ($wrev && $meta && ($wrev=~/^-/)) 625 { 626 # previously removed file, add back 627 $log->info("added file $filename was previously removed, send $meta->{revision}"); 628 629 print "MT +updated\n"; 630 print "MT text U \n"; 631 print "MT fname $filename\n"; 632 print "MT newline\n"; 633 print "MT -updated\n"; 634 635 unless ( $state->{globaloptions}{-n} ) 636 { 637 my ( $filepart, $dirpart ) = filenamesplit($filename,1); 638 639 print "Created $dirpart\n"; 640 print $state->{CVSROOT} . "/$state->{module}/$filename\n"; 641 642 # this is an "entries" line 643 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash}); 644 my $entryLine = "/$filepart/$meta->{revision}//$kopts/"; 645 $entryLine .= getStickyTagOrDate($stickyInfo); 646 $log->debug($entryLine); 647 print "$entryLine\n"; 648 # permissions 649 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}"); 650 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n"; 651 # transmit file 652 transmitfile($meta->{filehash}); 653 } 654 655 next; 656 } 657 658 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) ) 659 { 660 print "E cvs add: nothing known about `$filename'\n"; 661 next; 662 } 663 # TODO : check we're not squashing an already existing file 664 if ( defined ( $state->{entries}{$filename}{revision} ) ) 665 { 666 print "E cvs add: `$filename' has already been entered\n"; 667 next; 668 } 669 670 my ( $filepart, $dirpart ) = filenamesplit($filename, 1); 671 672 print "E cvs add: scheduling file `$filename' for addition\n"; 673 674 print "Checked-in $dirpart\n"; 675 print "$filename\n"; 676 my $kopts = kopts_from_path($filename,"file", 677 $state->{entries}{$filename}{modified_filename}); 678 print "/$filepart/0//$kopts/" . 679 getStickyTagOrDate($stickyInfo) . "\n"; 680 681 my $requestedKopts = $state->{opt}{k}; 682 if(defined($requestedKopts)) 683 { 684 $requestedKopts = "-k$requestedKopts"; 685 } 686 else 687 { 688 $requestedKopts = ""; 689 } 690 if( $kopts ne $requestedKopts ) 691 { 692 $log->warn("Ignoring requested -k='$requestedKopts'" 693 . " for '$filename'; detected -k='$kopts' instead"); 694 #TODO: Also have option to send warning to user? 695 } 696 697 $addcount++; 698 } 699 700 if ( $addcount == 1 ) 701 { 702 print "E cvs add: use `cvs commit' to add this file permanently\n"; 703 } 704 elsif ( $addcount > 1 ) 705 { 706 print "E cvs add: use `cvs commit' to add these files permanently\n"; 707 } 708 709 print "ok\n"; 710} 711 712# remove \n 713# Response expected: yes. Remove a file. This uses any previous Argument, 714# Directory, Entry, or Modified requests, if they have been sent. The last 715# Directory sent specifies the working directory at the time of the 716# operation. Note that this request does not actually do anything to the 717# repository; the only effect of a successful remove request is to supply 718# the client with a new entries line containing `-' to indicate a removed 719# file. In fact, the client probably could perform this operation without 720# contacting the server, although using remove may cause the server to 721# perform a few more checks. The client sends a subsequent ci request to 722# actually record the removal in the repository. 723sub req_remove 724{ 725 my ( $cmd, $data ) = @_; 726 727 argsplit("remove"); 728 729 # Grab a handle to the SQLite db and do any necessary updates 730 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 731 $updater->update(); 732 733 #$log->debug("add state : " . Dumper($state)); 734 735 my $rmcount = 0; 736 737 foreach my $filename ( @{$state->{args}} ) 738 { 739 $filename = filecleanup($filename); 740 741 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) ) 742 { 743 print "E cvs remove: file `$filename' still in working directory\n"; 744 next; 745 } 746 747 # only from entries 748 my $stickyInfo = resolveStickyInfo($filename); 749 750 my $meta = $updater->getmeta($filename,$stickyInfo); 751 my $wrev = revparse($filename); 752 753 unless ( defined ( $wrev ) ) 754 { 755 print "E cvs remove: nothing known about `$filename'\n"; 756 next; 757 } 758 759 if ( defined($wrev) and ($wrev=~/^-/) ) 760 { 761 print "E cvs remove: file `$filename' already scheduled for removal\n"; 762 next; 763 } 764 765 unless ( $wrev eq $meta->{revision} ) 766 { 767 # TODO : not sure if the format of this message is quite correct. 768 print "E cvs remove: Up to date check failed for `$filename'\n"; 769 next; 770 } 771 772 773 my ( $filepart, $dirpart ) = filenamesplit($filename, 1); 774 775 print "E cvs remove: scheduling `$filename' for removal\n"; 776 777 print "Checked-in $dirpart\n"; 778 print "$filename\n"; 779 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash}); 780 print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n"; 781 782 $rmcount++; 783 } 784 785 if ( $rmcount == 1 ) 786 { 787 print "E cvs remove: use `cvs commit' to remove this file permanently\n"; 788 } 789 elsif ( $rmcount > 1 ) 790 { 791 print "E cvs remove: use `cvs commit' to remove these files permanently\n"; 792 } 793 794 print "ok\n"; 795} 796 797# Modified filename \n 798# Response expected: no. Additional data: mode, \n, file transmission. Send 799# the server a copy of one locally modified file. filename is a file within 800# the most recent directory sent with Directory; it must not contain `/'. 801# If the user is operating on only some files in a directory, only those 802# files need to be included. This can also be sent without Entry, if there 803# is no entry for the file. 804sub req_Modified 805{ 806 my ( $cmd, $data ) = @_; 807 808 my $mode = <STDIN>; 809 defined $mode 810 or (print "E end of file reading mode for $data\n"), return; 811 chomp $mode; 812 my $size = <STDIN>; 813 defined $size 814 or (print "E end of file reading size of $data\n"), return; 815 chomp $size; 816 817 # Grab config information 818 my $blocksize = 8192; 819 my $bytesleft = $size; 820 my $tmp; 821 822 # Get a filehandle/name to write it to 823 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR ); 824 825 # Loop over file data writing out to temporary file. 826 while ( $bytesleft ) 827 { 828 $blocksize = $bytesleft if ( $bytesleft < $blocksize ); 829 read STDIN, $tmp, $blocksize; 830 print $fh $tmp; 831 $bytesleft -= $blocksize; 832 } 833 834 close $fh 835 or (print "E failed to write temporary, $filename: $!\n"), return; 836 837 # Ensure we have something sensible for the file mode 838 if ( $mode =~ /u=(\w+)/ ) 839 { 840 $mode = $1; 841 } else { 842 $mode = "rw"; 843 } 844 845 # Save the file data in $state 846 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename; 847 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode; 848 $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename); 849 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s; 850 851 #$log->debug("req_Modified : file=$data mode=$mode size=$size"); 852} 853 854# Unchanged filename \n 855# Response expected: no. Tell the server that filename has not been 856# modified in the checked out directory. The filename is a file within the 857# most recent directory sent with Directory; it must not contain `/'. 858sub req_Unchanged 859{ 860 my ( $cmd, $data ) = @_; 861 862 $state->{entries}{$state->{directory}.$data}{unchanged} = 1; 863 864 #$log->debug("req_Unchanged : $data"); 865} 866 867# Argument text \n 868# Response expected: no. Save argument for use in a subsequent command. 869# Arguments accumulate until an argument-using command is given, at which 870# point they are forgotten. 871# Argumentx text \n 872# Response expected: no. Append \n followed by text to the current argument 873# being saved. 874sub req_Argument 875{ 876 my ( $cmd, $data ) = @_; 877 878 # Argumentx means: append to last Argument (with a newline in front) 879 880 $log->debug("$cmd : $data"); 881 882 if ( $cmd eq 'Argumentx') { 883 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data; 884 } else { 885 push @{$state->{arguments}}, $data; 886 } 887} 888 889# expand-modules \n 890# Response expected: yes. Expand the modules which are specified in the 891# arguments. Returns the data in Module-expansion responses. Note that the 892# server can assume that this is checkout or export, not rtag or rdiff; the 893# latter do not access the working directory and thus have no need to 894# expand modules on the client side. Expand may not be the best word for 895# what this request does. It does not necessarily tell you all the files 896# contained in a module, for example. Basically it is a way of telling you 897# which working directories the server needs to know about in order to 898# handle a checkout of the specified modules. For example, suppose that the 899# server has a module defined by 900# aliasmodule -a 1dir 901# That is, one can check out aliasmodule and it will take 1dir in the 902# repository and check it out to 1dir in the working directory. Now suppose 903# the client already has this module checked out and is planning on using 904# the co request to update it. Without using expand-modules, the client 905# would have two bad choices: it could either send information about all 906# working directories under the current directory, which could be 907# unnecessarily slow, or it could be ignorant of the fact that aliasmodule 908# stands for 1dir, and neglect to send information for 1dir, which would 909# lead to incorrect operation. With expand-modules, the client would first 910# ask for the module to be expanded: 911sub req_expandmodules 912{ 913 my ( $cmd, $data ) = @_; 914 915 argsplit(); 916 917 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) ); 918 919 unless ( ref $state->{arguments} eq "ARRAY" ) 920 { 921 print "ok\n"; 922 return; 923 } 924 925 foreach my $module ( @{$state->{arguments}} ) 926 { 927 $log->debug("SEND : Module-expansion $module"); 928 print "Module-expansion $module\n"; 929 } 930 931 print "ok\n"; 932 statecleanup(); 933} 934 935# co \n 936# Response expected: yes. Get files from the repository. This uses any 937# previous Argument, Directory, Entry, or Modified requests, if they have 938# been sent. Arguments to this command are module names; the client cannot 939# know what directories they correspond to except by (1) just sending the 940# co request, and then seeing what directory names the server sends back in 941# its responses, and (2) the expand-modules request. 942sub req_co 943{ 944 my ( $cmd, $data ) = @_; 945 946 argsplit("co"); 947 948 # Provide list of modules, if -c was used. 949 if (exists $state->{opt}{c}) { 950 my $showref = safe_pipe_capture(qw(git show-ref --heads)); 951 for my $line (split '\n', $showref) { 952 if ( $line =~ m% refs/heads/(.*)$% ) { 953 print "M $1\t$1\n"; 954 } 955 } 956 print "ok\n"; 957 return 1; 958 } 959 960 my $stickyInfo = { 'tag' => $state->{opt}{r}, 961 'date' => $state->{opt}{D} }; 962 963 my $module = $state->{args}[0]; 964 $state->{module} = $module; 965 my $checkout_path = $module; 966 967 # use the user specified directory if we're given it 968 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) ); 969 970 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) ); 971 972 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'"); 973 974 $ENV{GIT_DIR} = $state->{CVSROOT} . "/"; 975 976 # Grab a handle to the SQLite db and do any necessary updates 977 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log); 978 $updater->update(); 979 980 my $headHash; 981 if( defined($stickyInfo) && defined($stickyInfo->{tag}) ) 982 { 983 $headHash = $updater->lookupCommitRef($stickyInfo->{tag}); 984 if( !defined($headHash) ) 985 { 986 print "error 1 no such tag `$stickyInfo->{tag}'\n"; 987 cleanupWorkTree(); 988 exit; 989 } 990 } 991 992 $checkout_path =~ s|/$||; # get rid of trailing slashes 993 994 my %seendirs = (); 995 my $lastdir =''; 996 997 prepDirForOutput( 998 ".", 999 $state->{CVSROOT} . "/$module", 1000 $checkout_path, 1001 \%seendirs, 1002 'checkout', 1003 $state->{dirArgs} ); 1004 1005 foreach my $git ( @{$updater->getAnyHead($headHash)} ) 1006 { 1007 # Don't want to check out deleted files 1008 next if ( $git->{filehash} eq "deleted" ); 1009 1010 my $fullName = $git->{name}; 1011 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name}); 1012 1013 unless (exists($seendirs{$git->{dir}})) { 1014 prepDirForOutput($git->{dir}, $state->{CVSROOT} . "/$module/", 1015 $checkout_path, \%seendirs, 'checkout', 1016 $state->{dirArgs} ); 1017 $lastdir = $git->{dir}; 1018 $seendirs{$git->{dir}} = 1; 1019 } 1020 1021 # modification time of this file 1022 print "Mod-time $git->{modified}\n"; 1023 1024 # print some information to the client 1025 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" ) 1026 { 1027 print "M U $checkout_path/$git->{dir}$git->{name}\n"; 1028 } else { 1029 print "M U $checkout_path/$git->{name}\n"; 1030 } 1031 1032 # instruct client we're sending a file to put in this path 1033 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n"; 1034 1035 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n"; 1036 1037 # this is an "entries" line 1038 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash}); 1039 print "/$git->{name}/$git->{revision}//$kopts/" . 1040 getStickyTagOrDate($stickyInfo) . "\n"; 1041 # permissions 1042 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n"; 1043 1044 # transmit file 1045 transmitfile($git->{filehash}); 1046 } 1047 1048 print "ok\n"; 1049 1050 statecleanup(); 1051} 1052 1053# used by req_co and req_update to set up directories for files 1054# recursively handles parents 1055sub prepDirForOutput 1056{ 1057 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_; 1058 1059 my $parent = dirname($dir); 1060 $dir =~ s|/+$||; 1061 $repodir =~ s|/+$||; 1062 $remotedir =~ s|/+$||; 1063 $parent =~ s|/+$||; 1064 1065 if ($parent eq '.' || $parent eq './') 1066 { 1067 $parent = ''; 1068 } 1069 # recurse to announce unseen parents first 1070 if( length($parent) && 1071 !exists($seendirs->{$parent}) && 1072 ( $request eq "checkout" || 1073 exists($dirArgs->{$parent}) ) ) 1074 { 1075 prepDirForOutput($parent, $repodir, $remotedir, 1076 $seendirs, $request, $dirArgs); 1077 } 1078 # Announce that we are going to modify at the parent level 1079 if ($dir eq '.' || $dir eq './') 1080 { 1081 $dir = ''; 1082 } 1083 if(exists($seendirs->{$dir})) 1084 { 1085 return; 1086 } 1087 $log->debug("announcedir $dir, $repodir, $remotedir" ); 1088 my($thisRemoteDir,$thisRepoDir); 1089 if ($dir ne "") 1090 { 1091 $thisRepoDir="$repodir/$dir"; 1092 if($remotedir eq ".") 1093 { 1094 $thisRemoteDir=$dir; 1095 } 1096 else 1097 { 1098 $thisRemoteDir="$remotedir/$dir"; 1099 } 1100 } 1101 else 1102 { 1103 $thisRepoDir=$repodir; 1104 $thisRemoteDir=$remotedir; 1105 } 1106 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} ) 1107 { 1108 print "E cvs $request: Updating $thisRemoteDir\n"; 1109 } 1110 1111 my ($opt_r)=$state->{opt}{r}; 1112 my $stickyInfo; 1113 if(exists($state->{opt}{A})) 1114 { 1115 # $stickyInfo=undef; 1116 } 1117 elsif( defined($opt_r) && $opt_r ne "" ) 1118 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO 1119 { 1120 $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) }; 1121 1122 # TODO: Convert -D value into the form 2011.04.10.04.46.57, 1123 # similar to an entry line's sticky date, without the D prefix. 1124 # It sometimes (always?) arrives as something more like 1125 # '10 Apr 2011 04:46:57 -0000'... 1126 # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) }; 1127 } 1128 else 1129 { 1130 $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir); 1131 } 1132 1133 my $stickyResponse; 1134 if(defined($stickyInfo)) 1135 { 1136 $stickyResponse = "Set-sticky $thisRemoteDir/\n" . 1137 "$thisRepoDir/\n" . 1138 getStickyTagOrDate($stickyInfo) . "\n"; 1139 } 1140 else 1141 { 1142 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" . 1143 "$thisRepoDir/\n"; 1144 } 1145 1146 unless ( $state->{globaloptions}{-n} ) 1147 { 1148 print $stickyResponse; 1149 1150 print "Clear-static-directory $thisRemoteDir/\n"; 1151 print "$thisRepoDir/\n"; 1152 print $stickyResponse; # yes, twice 1153 print "Template $thisRemoteDir/\n"; 1154 print "$thisRepoDir/\n"; 1155 print "0\n"; 1156 } 1157 1158 $seendirs->{$dir} = 1; 1159 1160 # FUTURE: This would more accurately emulate CVS by sending 1161 # another copy of sticky after processing the files in that 1162 # directory. Or intermediate: perhaps send all sticky's for 1163 # $seendirs after processing all files. 1164} 1165 1166# update \n 1167# Response expected: yes. Actually do a cvs update command. This uses any 1168# previous Argument, Directory, Entry, or Modified requests, if they have 1169# been sent. The last Directory sent specifies the working directory at the 1170# time of the operation. The -I option is not used--files which the client 1171# can decide whether to ignore are not mentioned and the client sends the 1172# Questionable request for others. 1173sub req_update 1174{ 1175 my ( $cmd, $data ) = @_; 1176 1177 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" )); 1178 1179 argsplit("update"); 1180 1181 # 1182 # It may just be a client exploring the available heads/modules 1183 # in that case, list them as top level directories and leave it 1184 # at that. Eclipse uses this technique to offer you a list of 1185 # projects (heads in this case) to checkout. 1186 # 1187 if ($state->{module} eq '') { 1188 my $showref = safe_pipe_capture(qw(git show-ref --heads)); 1189 print "E cvs update: Updating .\n"; 1190 for my $line (split '\n', $showref) { 1191 if ( $line =~ m% refs/heads/(.*)$% ) { 1192 print "E cvs update: New directory `$1'\n"; 1193 } 1194 } 1195 print "ok\n"; 1196 return 1; 1197 } 1198 1199 1200 # Grab a handle to the SQLite db and do any necessary updates 1201 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 1202 1203 $updater->update(); 1204 1205 argsfromdir($updater); 1206 1207 #$log->debug("update state : " . Dumper($state)); 1208 1209 my($repoDir); 1210 $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}"; 1211 1212 my %seendirs = (); 1213 1214 # foreach file specified on the command line ... 1215 foreach my $argsFilename ( @{$state->{args}} ) 1216 { 1217 my $filename; 1218 $filename = filecleanup($argsFilename); 1219 1220 $log->debug("Processing file $filename"); 1221 1222 # if we have a -C we should pretend we never saw modified stuff 1223 if ( exists ( $state->{opt}{C} ) ) 1224 { 1225 delete $state->{entries}{$filename}{modified_hash}; 1226 delete $state->{entries}{$filename}{modified_filename}; 1227 $state->{entries}{$filename}{unchanged} = 1; 1228 } 1229 1230 my $stickyInfo = resolveStickyInfo($filename, 1231 $state->{opt}{r}, 1232 $state->{opt}{D}, 1233 exists($state->{opt}{A})); 1234 my $meta = $updater->getmeta($filename, $stickyInfo); 1235 1236 # If -p was given, "print" the contents of the requested revision. 1237 if ( exists ( $state->{opt}{p} ) ) { 1238 if ( defined ( $meta->{revision} ) ) { 1239 $log->info("Printing '$filename' revision " . $meta->{revision}); 1240 1241 transmitfile($meta->{filehash}, { print => 1 }); 1242 } 1243 1244 next; 1245 } 1246 1247 # Directories: 1248 prepDirForOutput( 1249 dirname($argsFilename), 1250 $repoDir, 1251 ".", 1252 \%seendirs, 1253 "update", 1254 $state->{dirArgs} ); 1255 1256 my $wrev = revparse($filename); 1257 1258 if ( ! defined $meta ) 1259 { 1260 $meta = { 1261 name => $filename, 1262 revision => '0', 1263 filehash => 'added' 1264 }; 1265 if($wrev ne "0") 1266 { 1267 $meta->{filehash}='deleted'; 1268 } 1269 } 1270 1271 my $oldmeta = $meta; 1272 1273 # If the working copy is an old revision, lets get that version too for comparison. 1274 my $oldWrev=$wrev; 1275 if(defined($oldWrev)) 1276 { 1277 $oldWrev=~s/^-//; 1278 if($oldWrev ne $meta->{revision}) 1279 { 1280 $oldmeta = $updater->getmeta($filename, $oldWrev); 1281 } 1282 } 1283 1284 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev"); 1285 1286 # Files are up to date if the working copy and repo copy have the same revision, 1287 # and the working copy is unmodified _and_ the user hasn't specified -C 1288 next if ( defined ( $wrev ) 1289 and defined($meta->{revision}) 1290 and $wrev eq $meta->{revision} 1291 and $state->{entries}{$filename}{unchanged} 1292 and not exists ( $state->{opt}{C} ) ); 1293 1294 # If the working copy and repo copy have the same revision, 1295 # but the working copy is modified, tell the client it's modified 1296 if ( defined ( $wrev ) 1297 and defined($meta->{revision}) 1298 and $wrev eq $meta->{revision} 1299 and $wrev ne "0" 1300 and defined($state->{entries}{$filename}{modified_hash}) 1301 and not exists ( $state->{opt}{C} ) ) 1302 { 1303 $log->info("Tell the client the file is modified"); 1304 print "MT text M \n"; 1305 print "MT fname $filename\n"; 1306 print "MT newline\n"; 1307 next; 1308 } 1309 1310 if ( $meta->{filehash} eq "deleted" && $wrev ne "0" ) 1311 { 1312 # TODO: If it has been modified in the sandbox, error out 1313 # with the appropriate message, rather than deleting a modified 1314 # file. 1315 1316 my ( $filepart, $dirpart ) = filenamesplit($filename,1); 1317 1318 $log->info("Removing '$filename' from working copy (no longer in the repo)"); 1319 1320 print "E cvs update: `$filename' is no longer in the repository\n"; 1321 # Don't want to actually _DO_ the update if -n specified 1322 unless ( $state->{globaloptions}{-n} ) { 1323 print "Removed $dirpart\n"; 1324 print "$filepart\n"; 1325 } 1326 } 1327 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} ) 1328 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} 1329 or $meta->{filehash} eq 'added' ) 1330 { 1331 # normal update, just send the new revision (either U=Update, 1332 # or A=Add, or R=Remove) 1333 if ( defined($wrev) && ($wrev=~/^-/) ) 1334 { 1335 $log->info("Tell the client the file is scheduled for removal"); 1336 print "MT text R \n"; 1337 print "MT fname $filename\n"; 1338 print "MT newline\n"; 1339 next; 1340 } 1341 elsif ( (!defined($wrev) || $wrev eq '0') && 1342 (!defined($meta->{revision}) || $meta->{revision} eq '0') ) 1343 { 1344 $log->info("Tell the client the file is scheduled for addition"); 1345 print "MT text A \n"; 1346 print "MT fname $filename\n"; 1347 print "MT newline\n"; 1348 next; 1349 1350 } 1351 else { 1352 $log->info("UpdatingX3 '$filename' to ".$meta->{revision}); 1353 print "MT +updated\n"; 1354 print "MT text U \n"; 1355 print "MT fname $filename\n"; 1356 print "MT newline\n"; 1357 print "MT -updated\n"; 1358 } 1359 1360 my ( $filepart, $dirpart ) = filenamesplit($filename,1); 1361 1362 # Don't want to actually _DO_ the update if -n specified 1363 unless ( $state->{globaloptions}{-n} ) 1364 { 1365 if ( defined ( $wrev ) ) 1366 { 1367 # instruct client we're sending a file to put in this path as a replacement 1368 print "Update-existing $dirpart\n"; 1369 $log->debug("Updating existing file 'Update-existing $dirpart'"); 1370 } else { 1371 # instruct client we're sending a file to put in this path as a new file 1372 1373 $log->debug("Creating new file 'Created $dirpart'"); 1374 print "Created $dirpart\n"; 1375 } 1376 print $state->{CVSROOT} . "/$state->{module}/$filename\n"; 1377 1378 # this is an "entries" line 1379 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash}); 1380 my $entriesLine = "/$filepart/$meta->{revision}//$kopts/"; 1381 $entriesLine .= getStickyTagOrDate($stickyInfo); 1382 $log->debug($entriesLine); 1383 print "$entriesLine\n"; 1384 1385 # permissions 1386 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}"); 1387 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n"; 1388 1389 # transmit file 1390 transmitfile($meta->{filehash}); 1391 } 1392 } else { 1393 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1); 1394 1395 my $mergeDir = setupTmpDir(); 1396 1397 my $file_local = $filepart . ".mine"; 1398 my $mergedFile = "$mergeDir/$file_local"; 1399 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local); 1400 my $file_old = $filepart . "." . $oldmeta->{revision}; 1401 transmitfile($oldmeta->{filehash}, { targetfile => $file_old }); 1402 my $file_new = $filepart . "." . $meta->{revision}; 1403 transmitfile($meta->{filehash}, { targetfile => $file_new }); 1404 1405 # we need to merge with the local changes ( M=successful merge, C=conflict merge ) 1406 $log->info("Merging $file_local, $file_old, $file_new"); 1407 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n"; 1408 1409 $log->debug("Temporary directory for merge is $mergeDir"); 1410 1411 my $return = system("git", "merge-file", $file_local, $file_old, $file_new); 1412 $return >>= 8; 1413 1414 cleanupTmpDir(); 1415 1416 if ( $return == 0 ) 1417 { 1418 $log->info("Merged successfully"); 1419 print "M M $filename\n"; 1420 $log->debug("Merged $dirpart"); 1421 1422 # Don't want to actually _DO_ the update if -n specified 1423 unless ( $state->{globaloptions}{-n} ) 1424 { 1425 print "Merged $dirpart\n"; 1426 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename"); 1427 print $state->{CVSROOT} . "/$state->{module}/$filename\n"; 1428 my $kopts = kopts_from_path("$dirpart/$filepart", 1429 "file",$mergedFile); 1430 $log->debug("/$filepart/$meta->{revision}//$kopts/"); 1431 my $entriesLine="/$filepart/$meta->{revision}//$kopts/"; 1432 $entriesLine .= getStickyTagOrDate($stickyInfo); 1433 print "$entriesLine\n"; 1434 } 1435 } 1436 elsif ( $return == 1 ) 1437 { 1438 $log->info("Merged with conflicts"); 1439 print "E cvs update: conflicts found in $filename\n"; 1440 print "M C $filename\n"; 1441 1442 # Don't want to actually _DO_ the update if -n specified 1443 unless ( $state->{globaloptions}{-n} ) 1444 { 1445 print "Merged $dirpart\n"; 1446 print $state->{CVSROOT} . "/$state->{module}/$filename\n"; 1447 my $kopts = kopts_from_path("$dirpart/$filepart", 1448 "file",$mergedFile); 1449 my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/"; 1450 $entriesLine .= getStickyTagOrDate($stickyInfo); 1451 print "$entriesLine\n"; 1452 } 1453 } 1454 else 1455 { 1456 $log->warn("Merge failed"); 1457 next; 1458 } 1459 1460 # Don't want to actually _DO_ the update if -n specified 1461 unless ( $state->{globaloptions}{-n} ) 1462 { 1463 # permissions 1464 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}"); 1465 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n"; 1466 1467 # transmit file, format is single integer on a line by itself (file 1468 # size) followed by the file contents 1469 # TODO : we should copy files in blocks 1470 my $data = safe_pipe_capture('cat', $mergedFile); 1471 $log->debug("File size : " . length($data)); 1472 print length($data) . "\n"; 1473 print $data; 1474 } 1475 } 1476 1477 } 1478 1479 # prepDirForOutput() any other existing directories unless they already 1480 # have the right sticky tag: 1481 unless ( $state->{globaloptions}{n} ) 1482 { 1483 my $dir; 1484 foreach $dir (keys(%{$state->{dirMap}})) 1485 { 1486 if( ! $seendirs{$dir} && 1487 exists($state->{dirArgs}{$dir}) ) 1488 { 1489 my($oldTag); 1490 $oldTag=$state->{dirMap}{$dir}{tagspec}; 1491 1492 unless( ( exists($state->{opt}{A}) && 1493 defined($oldTag) ) || 1494 ( defined($state->{opt}{r}) && 1495 ( !defined($oldTag) || 1496 $state->{opt}{r} ne $oldTag ) ) ) 1497 # TODO?: OR sticky dir is different... 1498 { 1499 next; 1500 } 1501 1502 prepDirForOutput( 1503 $dir, 1504 $repoDir, 1505 ".", 1506 \%seendirs, 1507 'update', 1508 $state->{dirArgs} ); 1509 } 1510 1511 # TODO?: Consider sending a final duplicate Sticky response 1512 # to more closely mimic real CVS. 1513 } 1514 } 1515 1516 print "ok\n"; 1517} 1518 1519sub req_ci 1520{ 1521 my ( $cmd, $data ) = @_; 1522 1523 argsplit("ci"); 1524 1525 #$log->debug("State : " . Dumper($state)); 1526 1527 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" )); 1528 1529 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' ) 1530 { 1531 print "error 1 anonymous user cannot commit via pserver\n"; 1532 cleanupWorkTree(); 1533 exit; 1534 } 1535 1536 if ( -e $state->{CVSROOT} . "/index" ) 1537 { 1538 $log->warn("file 'index' already exists in the git repository"); 1539 print "error 1 Index already exists in git repo\n"; 1540 cleanupWorkTree(); 1541 exit; 1542 } 1543 1544 # Grab a handle to the SQLite db and do any necessary updates 1545 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 1546 $updater->update(); 1547 1548 my @committedfiles = (); 1549 my %oldmeta; 1550 my $stickyInfo; 1551 my $branchRef; 1552 my $parenthash; 1553 1554 # foreach file specified on the command line ... 1555 foreach my $filename ( @{$state->{args}} ) 1556 { 1557 my $committedfile = $filename; 1558 $filename = filecleanup($filename); 1559 1560 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} ); 1561 1562 ##### 1563 # Figure out which branch and parenthash we are committing 1564 # to, and setup worktree: 1565 1566 # should always come from entries: 1567 my $fileStickyInfo = resolveStickyInfo($filename); 1568 if( !defined($branchRef) ) 1569 { 1570 $stickyInfo = $fileStickyInfo; 1571 if( defined($stickyInfo) && 1572 ( defined($stickyInfo->{date}) || 1573 !defined($stickyInfo->{tag}) ) ) 1574 { 1575 print "error 1 cannot commit with sticky date for file `$filename'\n"; 1576 cleanupWorkTree(); 1577 exit; 1578 } 1579 1580 $branchRef = "refs/heads/$state->{module}"; 1581 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) ) 1582 { 1583 $branchRef = "refs/heads/$stickyInfo->{tag}"; 1584 } 1585 1586 $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef); 1587 chomp $parenthash; 1588 if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/) 1589 { 1590 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) ) 1591 { 1592 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n"; 1593 } 1594 else 1595 { 1596 print "error 1 pserver cannot find the current HEAD of module"; 1597 } 1598 cleanupWorkTree(); 1599 exit; 1600 } 1601 1602 setupWorkTree($parenthash); 1603 1604 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'"); 1605 1606 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?"); 1607 } 1608 elsif( !refHashEqual($stickyInfo,$fileStickyInfo) ) 1609 { 1610 #TODO: We could split the cvs commit into multiple 1611 # git commits by distinct stickyTag values, but that 1612 # is lowish priority. 1613 print "error 1 Committing different files to different" 1614 . " branches is not currently supported\n"; 1615 cleanupWorkTree(); 1616 exit; 1617 } 1618 1619 ##### 1620 # Process this file: 1621 1622 my $meta = $updater->getmeta($filename,$stickyInfo); 1623 $oldmeta{$filename} = $meta; 1624 1625 my $wrev = revparse($filename); 1626 1627 my ( $filepart, $dirpart ) = filenamesplit($filename); 1628 1629 # do a checkout of the file if it is part of this tree 1630 if ($wrev) { 1631 system('git', 'checkout-index', '-f', '-u', $filename); 1632 unless ($? == 0) { 1633 die "Error running git-checkout-index -f -u $filename : $!"; 1634 } 1635 } 1636 1637 my $addflag = 0; 1638 my $rmflag = 0; 1639 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) ); 1640 $addflag = 1 unless ( -e $filename ); 1641 1642 # Do up to date checking 1643 unless ( $addflag or $wrev eq $meta->{revision} or 1644 ( $rmflag and $wrev eq "-$meta->{revision}" ) ) 1645 { 1646 # fail everything if an up to date check fails 1647 print "error 1 Up to date check failed for $filename\n"; 1648 cleanupWorkTree(); 1649 exit; 1650 } 1651 1652 push @committedfiles, $committedfile; 1653 $log->info("Committing $filename"); 1654 1655 system("mkdir","-p",$dirpart) unless ( -d $dirpart ); 1656 1657 unless ( $rmflag ) 1658 { 1659 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename"); 1660 rename $state->{entries}{$filename}{modified_filename},$filename; 1661 1662 # Calculate modes to remove 1663 my $invmode = ""; 1664 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); } 1665 1666 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename"); 1667 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename); 1668 } 1669 1670 if ( $rmflag ) 1671 { 1672 $log->info("Removing file '$filename'"); 1673 unlink($filename); 1674 system("git", "update-index", "--remove", $filename); 1675 } 1676 elsif ( $addflag ) 1677 { 1678 $log->info("Adding file '$filename'"); 1679 system("git", "update-index", "--add", $filename); 1680 } else { 1681 $log->info("UpdatingX2 file '$filename'"); 1682 system("git", "update-index", $filename); 1683 } 1684 } 1685 1686 unless ( scalar(@committedfiles) > 0 ) 1687 { 1688 print "E No files to commit\n"; 1689 print "ok\n"; 1690 cleanupWorkTree(); 1691 return; 1692 } 1693 1694 my $treehash = safe_pipe_capture(qw(git write-tree)); 1695 chomp $treehash; 1696 1697 $log->debug("Treehash : $treehash, Parenthash : $parenthash"); 1698 1699 # write our commit message out if we have one ... 1700 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR ); 1701 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) ); 1702 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) { 1703 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) { 1704 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n" 1705 } 1706 } else { 1707 print $msg_fh "\n\nvia git-CVS emulator\n"; 1708 } 1709 close $msg_fh; 1710 1711 my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename); 1712 chomp($commithash); 1713 $log->info("Commit hash : $commithash"); 1714 1715 unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ ) 1716 { 1717 $log->warn("Commit failed (Invalid commit hash)"); 1718 print "error 1 Commit failed (unknown reason)\n"; 1719 cleanupWorkTree(); 1720 exit; 1721 } 1722 1723 ### Emulate git-receive-pack by running hooks/update 1724 my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef, 1725 $parenthash, $commithash ); 1726 if( -x $hook[0] ) { 1727 unless( system( @hook ) == 0 ) 1728 { 1729 $log->warn("Commit failed (update hook declined to update ref)"); 1730 print "error 1 Commit failed (update hook declined)\n"; 1731 cleanupWorkTree(); 1732 exit; 1733 } 1734 } 1735 1736 ### Update the ref 1737 if (system(qw(git update-ref -m), "cvsserver ci", 1738 $branchRef, $commithash, $parenthash)) { 1739 $log->warn("update-ref for $state->{module} failed."); 1740 print "error 1 Cannot commit -- update first\n"; 1741 cleanupWorkTree(); 1742 exit; 1743 } 1744 1745 ### Emulate git-receive-pack by running hooks/post-receive 1746 my $hook = $ENV{GIT_DIR}.'hooks/post-receive'; 1747 if( -x $hook ) { 1748 open(my $pipe, "| $hook") || die "can't fork $!"; 1749 1750 local $SIG{PIPE} = sub { die 'pipe broke' }; 1751 1752 print $pipe "$parenthash $commithash $branchRef\n"; 1753 1754 close $pipe || die "bad pipe: $! $?"; 1755 } 1756 1757 $updater->update(); 1758 1759 ### Then hooks/post-update 1760 $hook = $ENV{GIT_DIR}.'hooks/post-update'; 1761 if (-x $hook) { 1762 system($hook, $branchRef); 1763 } 1764 1765 # foreach file specified on the command line ... 1766 foreach my $filename ( @committedfiles ) 1767 { 1768 $filename = filecleanup($filename); 1769 1770 my $meta = $updater->getmeta($filename,$stickyInfo); 1771 unless (defined $meta->{revision}) { 1772 $meta->{revision} = "1.1"; 1773 } 1774 1775 my ( $filepart, $dirpart ) = filenamesplit($filename, 1); 1776 1777 $log->debug("Checked-in $dirpart : $filename"); 1778 1779 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n"; 1780 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" ) 1781 { 1782 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n"; 1783 print "Remove-entry $dirpart\n"; 1784 print "$filename\n"; 1785 } else { 1786 if ($meta->{revision} eq "1.1") { 1787 print "M initial revision: 1.1\n"; 1788 } else { 1789 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n"; 1790 } 1791 print "Checked-in $dirpart\n"; 1792 print "$filename\n"; 1793 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash}); 1794 print "/$filepart/$meta->{revision}//$kopts/" . 1795 getStickyTagOrDate($stickyInfo) . "\n"; 1796 } 1797 } 1798 1799 cleanupWorkTree(); 1800 print "ok\n"; 1801} 1802 1803sub req_status 1804{ 1805 my ( $cmd, $data ) = @_; 1806 1807 argsplit("status"); 1808 1809 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" )); 1810 #$log->debug("status state : " . Dumper($state)); 1811 1812 # Grab a handle to the SQLite db and do any necessary updates 1813 my $updater; 1814 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 1815 $updater->update(); 1816 1817 # if no files were specified, we need to work out what files we should 1818 # be providing status on ... 1819 argsfromdir($updater); 1820 1821 # foreach file specified on the command line ... 1822 foreach my $filename ( @{$state->{args}} ) 1823 { 1824 $filename = filecleanup($filename); 1825 1826 if ( exists($state->{opt}{l}) && 1827 index($filename, '/', length($state->{prependdir})) >= 0 ) 1828 { 1829 next; 1830 } 1831 1832 my $wrev = revparse($filename); 1833 1834 my $stickyInfo = resolveStickyInfo($filename); 1835 my $meta = $updater->getmeta($filename,$stickyInfo); 1836 my $oldmeta = $meta; 1837 1838 # If the working copy is an old revision, lets get that 1839 # version too for comparison. 1840 if ( defined($wrev) and $wrev ne $meta->{revision} ) 1841 { 1842 my($rmRev)=$wrev; 1843 $rmRev=~s/^-//; 1844 $oldmeta = $updater->getmeta($filename, $rmRev); 1845 } 1846 1847 # TODO : All possible statuses aren't yet implemented 1848 my $status; 1849 # Files are up to date if the working copy and repo copy have 1850 # the same revision, and the working copy is unmodified 1851 if ( defined ( $wrev ) and defined($meta->{revision}) and 1852 $wrev eq $meta->{revision} and 1853 ( ( $state->{entries}{$filename}{unchanged} and 1854 ( not defined ( $state->{entries}{$filename}{conflict} ) or 1855 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or 1856 ( defined($state->{entries}{$filename}{modified_hash}) and 1857 $state->{entries}{$filename}{modified_hash} eq 1858 $meta->{filehash} ) ) ) 1859 { 1860 $status = "Up-to-date" 1861 } 1862 1863 # Need checkout if the working copy has a different (usually 1864 # older) revision than the repo copy, and the working copy is 1865 # unmodified 1866 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and 1867 $meta->{revision} ne $wrev and 1868 ( $state->{entries}{$filename}{unchanged} or 1869 ( defined($state->{entries}{$filename}{modified_hash}) and 1870 $state->{entries}{$filename}{modified_hash} eq 1871 $oldmeta->{filehash} ) ) ) 1872 { 1873 $status ||= "Needs Checkout"; 1874 } 1875 1876 # Need checkout if it exists in the repo but doesn't have a working 1877 # copy 1878 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) ) 1879 { 1880 $status ||= "Needs Checkout"; 1881 } 1882 1883 # Locally modified if working copy and repo copy have the 1884 # same revision but there are local changes 1885 if ( defined ( $wrev ) and defined($meta->{revision}) and 1886 $wrev eq $meta->{revision} and 1887 $wrev ne "0" and 1888 $state->{entries}{$filename}{modified_filename} ) 1889 { 1890 $status ||= "Locally Modified"; 1891 } 1892 1893 # Needs Merge if working copy revision is different 1894 # (usually older) than repo copy and there are local changes 1895 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and 1896 $meta->{revision} ne $wrev and 1897 $state->{entries}{$filename}{modified_filename} ) 1898 { 1899 $status ||= "Needs Merge"; 1900 } 1901 1902 if ( defined ( $state->{entries}{$filename}{revision} ) and 1903 ( !defined($meta->{revision}) || 1904 $meta->{revision} eq "0" ) ) 1905 { 1906 $status ||= "Locally Added"; 1907 } 1908 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and 1909 $wrev eq "-$meta->{revision}" ) 1910 { 1911 $status ||= "Locally Removed"; 1912 } 1913 if ( defined ( $state->{entries}{$filename}{conflict} ) and 1914 $state->{entries}{$filename}{conflict} =~ /^\+=/ ) 1915 { 1916 $status ||= "Unresolved Conflict"; 1917 } 1918 if ( 0 ) 1919 { 1920 $status ||= "File had conflicts on merge"; 1921 } 1922 1923 $status ||= "Unknown"; 1924 1925 my ($filepart) = filenamesplit($filename); 1926 1927 print "M =======" . ( "=" x 60 ) . "\n"; 1928 print "M File: $filepart\tStatus: $status\n"; 1929 if ( defined($state->{entries}{$filename}{revision}) ) 1930 { 1931 print "M Working revision:\t" . 1932 $state->{entries}{$filename}{revision} . "\n"; 1933 } else { 1934 print "M Working revision:\tNo entry for $filename\n"; 1935 } 1936 if ( defined($meta->{revision}) ) 1937 { 1938 print "M Repository revision:\t" . 1939 $meta->{revision} . 1940 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n"; 1941 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date}; 1942 my($tag)=($tagOrDate=~m/^T(.+)$/); 1943 if( !defined($tag) ) 1944 { 1945 $tag="(none)"; 1946 } 1947 print "M Sticky Tag:\t\t$tag\n"; 1948 my($date)=($tagOrDate=~m/^D(.+)$/); 1949 if( !defined($date) ) 1950 { 1951 $date="(none)"; 1952 } 1953 print "M Sticky Date:\t\t$date\n"; 1954 my($options)=$state->{entries}{$filename}{options}; 1955 if( $options eq "" ) 1956 { 1957 $options="(none)"; 1958 } 1959 print "M Sticky Options:\t\t$options\n"; 1960 } else { 1961 print "M Repository revision:\tNo revision control file\n"; 1962 } 1963 print "M\n"; 1964 } 1965 1966 print "ok\n"; 1967} 1968 1969sub req_diff 1970{ 1971 my ( $cmd, $data ) = @_; 1972 1973 argsplit("diff"); 1974 1975 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" )); 1976 #$log->debug("status state : " . Dumper($state)); 1977 1978 my ($revision1, $revision2); 1979 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" ) 1980 { 1981 $revision1 = $state->{opt}{r}[0]; 1982 $revision2 = $state->{opt}{r}[1]; 1983 } else { 1984 $revision1 = $state->{opt}{r}; 1985 } 1986 1987 $log->debug("Diffing revisions " . 1988 ( defined($revision1) ? $revision1 : "[NULL]" ) . 1989 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) ); 1990 1991 # Grab a handle to the SQLite db and do any necessary updates 1992 my $updater; 1993 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 1994 $updater->update(); 1995 1996 # if no files were specified, we need to work out what files we should 1997 # be providing status on ... 1998 argsfromdir($updater); 1999 2000 my($foundDiff); 2001 2002 # foreach file specified on the command line ... 2003 foreach my $argFilename ( @{$state->{args}} ) 2004 { 2005 my($filename) = filecleanup($argFilename); 2006 2007 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff ); 2008 2009 my $wrev = revparse($filename); 2010 2011 # Priority for revision1: 2012 # 1. First -r (missing file: check -N) 2013 # 2. wrev from client's Entry line 2014 # - missing line/file: check -N 2015 # - "0": added file not committed (empty contents for rev1) 2016 # - Prefixed with dash (to be removed): check -N 2017 2018 if ( defined ( $revision1 ) ) 2019 { 2020 $meta1 = $updater->getmeta($filename, $revision1); 2021 } 2022 elsif( defined($wrev) && $wrev ne "0" ) 2023 { 2024 my($rmRev)=$wrev; 2025 $rmRev=~s/^-//; 2026 $meta1 = $updater->getmeta($filename, $rmRev); 2027 } 2028 if ( !defined($meta1) || 2029 $meta1->{filehash} eq "deleted" ) 2030 { 2031 if( !exists($state->{opt}{N}) ) 2032 { 2033 if(!defined($revision1)) 2034 { 2035 print "E File $filename at revision $revision1 doesn't exist\n"; 2036 } 2037 next; 2038 } 2039 elsif( !defined($meta1) ) 2040 { 2041 $meta1 = { 2042 name => $filename, 2043 revision => '0', 2044 filehash => 'deleted' 2045 }; 2046 } 2047 } 2048 2049 # Priority for revision2: 2050 # 1. Second -r (missing file: check -N) 2051 # 2. Modified file contents from client 2052 # 3. wrev from client's Entry line 2053 # - missing line/file: check -N 2054 # - Prefixed with dash (to be removed): check -N 2055 2056 # if we have a second -r switch, use it too 2057 if ( defined ( $revision2 ) ) 2058 { 2059 $meta2 = $updater->getmeta($filename, $revision2); 2060 } 2061 elsif(defined($state->{entries}{$filename}{modified_filename})) 2062 { 2063 $file2 = $state->{entries}{$filename}{modified_filename}; 2064 $meta2 = { 2065 name => $filename, 2066 revision => '0', 2067 filehash => 'modified' 2068 }; 2069 } 2070 elsif( defined($wrev) && ($wrev!~/^-/) ) 2071 { 2072 if(!defined($revision1)) # no revision and no modifications: 2073 { 2074 next; 2075 } 2076 $meta2 = $updater->getmeta($filename, $wrev); 2077 } 2078 if(!defined($file2)) 2079 { 2080 if ( !defined($meta2) || 2081 $meta2->{filehash} eq "deleted" ) 2082 { 2083 if( !exists($state->{opt}{N}) ) 2084 { 2085 if(!defined($revision2)) 2086 { 2087 print "E File $filename at revision $revision2 doesn't exist\n"; 2088 } 2089 next; 2090 } 2091 elsif( !defined($meta2) ) 2092 { 2093 $meta2 = { 2094 name => $filename, 2095 revision => '0', 2096 filehash => 'deleted' 2097 }; 2098 } 2099 } 2100 } 2101 2102 if( $meta1->{filehash} eq $meta2->{filehash} ) 2103 { 2104 $log->info("unchanged $filename"); 2105 next; 2106 } 2107 2108 # Retrieve revision contents: 2109 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 ); 2110 transmitfile($meta1->{filehash}, { targetfile => $file1 }); 2111 2112 if(!defined($file2)) 2113 { 2114 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 ); 2115 transmitfile($meta2->{filehash}, { targetfile => $file2 }); 2116 } 2117 2118 # Generate the actual diff: 2119 print "M Index: $argFilename\n"; 2120 print "M =======" . ( "=" x 60 ) . "\n"; 2121 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n"; 2122 if ( defined ( $meta1 ) && $meta1->{revision} ne "0" ) 2123 { 2124 print "M retrieving revision $meta1->{revision}\n" 2125 } 2126 if ( defined ( $meta2 ) && $meta2->{revision} ne "0" ) 2127 { 2128 print "M retrieving revision $meta2->{revision}\n" 2129 } 2130 print "M diff "; 2131 foreach my $opt ( sort keys %{$state->{opt}} ) 2132 { 2133 if ( ref $state->{opt}{$opt} eq "ARRAY" ) 2134 { 2135 foreach my $value ( @{$state->{opt}{$opt}} ) 2136 { 2137 print "-$opt $value "; 2138 } 2139 } else { 2140 print "-$opt "; 2141 if ( defined ( $state->{opt}{$opt} ) ) 2142 { 2143 print "$state->{opt}{$opt} " 2144 } 2145 } 2146 } 2147 print "$argFilename\n"; 2148 2149 $log->info("Diffing $filename -r $meta1->{revision} -r " . 2150 ( $meta2->{revision} or "workingcopy" )); 2151 2152 # TODO: Use --label instead of -L because -L is no longer 2153 # documented and may go away someday. Not sure if there are 2154 # versions that only support -L, which would make this change risky? 2155 # http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html 2156 # ("man diff" should actually document the best migration strategy, 2157 # [current behavior, future changes, old compatibility issues 2158 # or lack thereof, etc], not just stop mentioning the option...) 2159 # TODO: Real CVS seems to include a date in the label, before 2160 # the revision part, without the keyword "revision". The following 2161 # has minimal changes compared to original versions of 2162 # git-cvsserver.perl. (Mostly tab vs space after filename.) 2163 2164 my (@diffCmd) = ( 'diff' ); 2165 if ( exists($state->{opt}{N}) ) 2166 { 2167 push @diffCmd,"-N"; 2168 } 2169 if ( exists $state->{opt}{u} ) 2170 { 2171 push @diffCmd,("-u","-L"); 2172 if( $meta1->{filehash} eq "deleted" ) 2173 { 2174 push @diffCmd,"/dev/null"; 2175 } else { 2176 push @diffCmd,("$argFilename\trevision $meta1->{revision}"); 2177 } 2178 2179 if( defined($meta2->{filehash}) ) 2180 { 2181 if( $meta2->{filehash} eq "deleted" ) 2182 { 2183 push @diffCmd,("-L","/dev/null"); 2184 } else { 2185 push @diffCmd,("-L", 2186 "$argFilename\trevision $meta2->{revision}"); 2187 } 2188 } else { 2189 push @diffCmd,("-L","$argFilename\tworking copy"); 2190 } 2191 } 2192 push @diffCmd,($file1,$file2); 2193 if(!open(DIFF,"-|",@diffCmd)) 2194 { 2195 $log->warn("Unable to run diff: $!"); 2196 } 2197 my($diffLine); 2198 while(defined($diffLine=<DIFF>)) 2199 { 2200 print "M $diffLine"; 2201 $foundDiff=1; 2202 } 2203 close(DIFF); 2204 } 2205 2206 if($foundDiff) 2207 { 2208 print "error \n"; 2209 } 2210 else 2211 { 2212 print "ok\n"; 2213 } 2214} 2215 2216sub req_log 2217{ 2218 my ( $cmd, $data ) = @_; 2219 2220 argsplit("log"); 2221 2222 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" )); 2223 #$log->debug("log state : " . Dumper($state)); 2224 2225 my ( $revFilter ); 2226 if ( defined ( $state->{opt}{r} ) ) 2227 { 2228 $revFilter = $state->{opt}{r}; 2229 } 2230 2231 # Grab a handle to the SQLite db and do any necessary updates 2232 my $updater; 2233 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 2234 $updater->update(); 2235 2236 # if no files were specified, we need to work out what files we 2237 # should be providing status on ... 2238 argsfromdir($updater); 2239 2240 # foreach file specified on the command line ... 2241 foreach my $filename ( @{$state->{args}} ) 2242 { 2243 $filename = filecleanup($filename); 2244 2245 my $headmeta = $updater->getmeta($filename); 2246 2247 my ($revisions,$totalrevisions) = $updater->getlog($filename, 2248 $revFilter); 2249 2250 next unless ( scalar(@$revisions) ); 2251 2252 print "M \n"; 2253 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n"; 2254 print "M Working file: $filename\n"; 2255 print "M head: $headmeta->{revision}\n"; 2256 print "M branch:\n"; 2257 print "M locks: strict\n"; 2258 print "M access list:\n"; 2259 print "M symbolic names:\n"; 2260 print "M keyword substitution: kv\n"; 2261 print "M total revisions: $totalrevisions;\tselected revisions: " . 2262 scalar(@$revisions) . "\n"; 2263 print "M description:\n"; 2264 2265 foreach my $revision ( @$revisions ) 2266 { 2267 print "M ----------------------------\n"; 2268 print "M revision $revision->{revision}\n"; 2269 # reformat the date for log output 2270 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and 2271 defined($DATE_LIST->{$2}) ) 2272 { 2273 $revision->{modified} = sprintf('%04d/%02d/%02d %s', 2274 $3, $DATE_LIST->{$2}, $1, $4 ); 2275 } 2276 $revision->{author} = cvs_author($revision->{author}); 2277 print "M date: $revision->{modified};" . 2278 " author: $revision->{author}; state: " . 2279 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . 2280 "; lines: +2 -3\n"; 2281 my $commitmessage; 2282 $commitmessage = $updater->commitmessage($revision->{commithash}); 2283 $commitmessage =~ s/^/M /mg; 2284 print $commitmessage . "\n"; 2285 } 2286 print "M =======" . ( "=" x 70 ) . "\n"; 2287 } 2288 2289 print "ok\n"; 2290} 2291 2292sub req_annotate 2293{ 2294 my ( $cmd, $data ) = @_; 2295 2296 argsplit("annotate"); 2297 2298 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" )); 2299 #$log->debug("status state : " . Dumper($state)); 2300 2301 # Grab a handle to the SQLite db and do any necessary updates 2302 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log); 2303 $updater->update(); 2304 2305 # if no files were specified, we need to work out what files we should be providing annotate on ... 2306 argsfromdir($updater); 2307 2308 # we'll need a temporary checkout dir 2309 setupWorkTree(); 2310 2311 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'"); 2312 2313 # foreach file specified on the command line ... 2314 foreach my $filename ( @{$state->{args}} ) 2315 { 2316 $filename = filecleanup($filename); 2317 2318 my $meta = $updater->getmeta($filename); 2319 2320 next unless ( $meta->{revision} ); 2321 2322 # get all the commits that this file was in 2323 # in dense format -- aka skip dead revisions 2324 my $revisions = $updater->gethistorydense($filename); 2325 my $lastseenin = $revisions->[0][2]; 2326 2327 # populate the temporary index based on the latest commit were we saw 2328 # the file -- but do it cheaply without checking out any files 2329 # TODO: if we got a revision from the client, use that instead 2330 # to look up the commithash in sqlite (still good to default to 2331 # the current head as we do now) 2332 system("git", "read-tree", $lastseenin); 2333 unless ($? == 0) 2334 { 2335 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n"; 2336 return; 2337 } 2338 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?"); 2339 2340 # do a checkout of the file 2341 system('git', 'checkout-index', '-f', '-u', $filename); 2342 unless ($? == 0) { 2343 print "E error running git-checkout-index -f -u $filename : $!\n"; 2344 return; 2345 } 2346 2347 $log->info("Annotate $filename"); 2348 2349 # Prepare a file with the commits from the linearized 2350 # history that annotate should know about. This prevents 2351 # git-jsannotate telling us about commits we are hiding 2352 # from the client. 2353 2354 my $a_hints = "$work->{workDir}/.annotate_hints"; 2355 if (!open(ANNOTATEHINTS, '>', $a_hints)) { 2356 print "E failed to open '$a_hints' for writing: $!\n"; 2357 return; 2358 } 2359 for (my $i=0; $i < @$revisions; $i++) 2360 { 2361 print ANNOTATEHINTS $revisions->[$i][2]; 2362 if ($i+1 < @$revisions) { # have we got a parent? 2363 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2]; 2364 } 2365 print ANNOTATEHINTS "\n"; 2366 } 2367 2368 print ANNOTATEHINTS "\n"; 2369 close ANNOTATEHINTS 2370 or (print "E failed to write $a_hints: $!\n"), return; 2371 2372 my @cmd = (qw(git annotate -l -S), $a_hints, $filename); 2373 if (!open(ANNOTATE, "-|", @cmd)) { 2374 print "E error invoking ". join(' ',@cmd) .": $!\n"; 2375 return; 2376 } 2377 my $metadata = {}; 2378 print "E Annotations for $filename\n"; 2379 print "E ***************\n"; 2380 while ( <ANNOTATE> ) 2381 { 2382 if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i) 2383 { 2384 my $commithash = $1; 2385 my $data = $2; 2386 unless ( defined ( $metadata->{$commithash} ) ) 2387 { 2388 $metadata->{$commithash} = $updater->getmeta($filename, $commithash); 2389 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author}); 2390 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ ); 2391 } 2392 printf("M %-7s (%-8s %10s): %s\n", 2393 $metadata->{$commithash}{revision}, 2394 $metadata->{$commithash}{author}, 2395 $metadata->{$commithash}{modified}, 2396 $data 2397 ); 2398 } else { 2399 $log->warn("Error in annotate output! LINE: $_"); 2400 print "E Annotate error \n"; 2401 next; 2402 } 2403 } 2404 close ANNOTATE; 2405 } 2406 2407 # done; get out of the tempdir 2408 cleanupWorkTree(); 2409 2410 print "ok\n"; 2411 2412} 2413 2414# This method takes the state->{arguments} array and produces two new arrays. 2415# The first is $state->{args} which is everything before the '--' argument, and 2416# the second is $state->{files} which is everything after it. 2417sub argsplit 2418{ 2419 $state->{args} = []; 2420 $state->{files} = []; 2421 $state->{opt} = {}; 2422 2423 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" ); 2424 2425 my $type = shift; 2426 2427 if ( defined($type) ) 2428 { 2429 my $opt = {}; 2430 $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" ); 2431 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" ); 2432 $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" ); 2433 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" ); 2434 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" ); 2435 $opt = { k => 1, m => 1 } if ( $type eq "add" ); 2436 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" ); 2437 $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" ); 2438 2439 2440 while ( scalar ( @{$state->{arguments}} ) > 0 ) 2441 { 2442 my $arg = shift @{$state->{arguments}}; 2443 2444 next if ( $arg eq "--" ); 2445 next unless ( $arg =~ /\S/ ); 2446 2447 # if the argument looks like a switch 2448 if ( $arg =~ /^-(\w)(.*)/ ) 2449 { 2450 # if it's a switch that takes an argument 2451 if ( $opt->{$1} ) 2452 { 2453 # If this switch has already been provided 2454 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) ) 2455 { 2456 $state->{opt}{$1} = [ $state->{opt}{$1} ]; 2457 if ( length($2) > 0 ) 2458 { 2459 push @{$state->{opt}{$1}},$2; 2460 } else { 2461 push @{$state->{opt}{$1}}, shift @{$state->{arguments}}; 2462 } 2463 } else { 2464 # if there's extra data in the arg, use that as the argument for the switch 2465 if ( length($2) > 0 ) 2466 { 2467 $state->{opt}{$1} = $2; 2468 } else { 2469 $state->{opt}{$1} = shift @{$state->{arguments}}; 2470 } 2471 } 2472 } else { 2473 $state->{opt}{$1} = undef; 2474 } 2475 } 2476 else 2477 { 2478 push @{$state->{args}}, $arg; 2479 } 2480 } 2481 } 2482 else 2483 { 2484 my $mode = 0; 2485 2486 foreach my $value ( @{$state->{arguments}} ) 2487 { 2488 if ( $value eq "--" ) 2489 { 2490 $mode++; 2491 next; 2492 } 2493 push @{$state->{args}}, $value if ( $mode == 0 ); 2494 push @{$state->{files}}, $value if ( $mode == 1 ); 2495 } 2496 } 2497} 2498 2499# Used by argsfromdir 2500sub expandArg 2501{ 2502 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_; 2503 2504 my $fullPath = filecleanup($path); 2505 2506 # Is it a directory? 2507 if( defined($state->{dirMap}{$fullPath}) || 2508 defined($state->{dirMap}{"$fullPath/"}) ) 2509 { 2510 # It is a directory in the user's sandbox. 2511 $isDir=1; 2512 2513 if(defined($state->{entries}{$fullPath})) 2514 { 2515 $log->fatal("Inconsistent file/dir type"); 2516 die "Inconsistent file/dir type"; 2517 } 2518 } 2519 elsif(defined($state->{entries}{$fullPath})) 2520 { 2521 # It is a file in the user's sandbox. 2522 $isDir=0; 2523 } 2524 my($revDirMap,$otherRevDirMap); 2525 if(!defined($isDir) || $isDir) 2526 { 2527 # Resolve version tree for sticky tag: 2528 # (for now we only want list of files for the version, not 2529 # particular versions of those files: assume it is a directory 2530 # for the moment; ignore Entry's stick tag) 2531 2532 # Order of precedence of sticky tags: 2533 # -A [head] 2534 # -r /tag/ 2535 # [file entry sticky tag, but that is only relevant to files] 2536 # [the tag specified in dir req_Sticky] 2537 # [the tag specified in a parent dir req_Sticky] 2538 # [head] 2539 # Also, -r may appear twice (for diff). 2540 # 2541 # FUTURE: When/if -j (merges) are supported, we also 2542 # need to add relevant files from one or two 2543 # versions specified with -j. 2544 2545 if(exists($state->{opt}{A})) 2546 { 2547 $revDirMap=$updater->getRevisionDirMap(); 2548 } 2549 elsif( defined($state->{opt}{r}) and 2550 ref $state->{opt}{r} eq "ARRAY" ) 2551 { 2552 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]); 2553 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]); 2554 } 2555 elsif(defined($state->{opt}{r})) 2556 { 2557 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}); 2558 } 2559 else 2560 { 2561 my($sticky)=getDirStickyInfo($fullPath); 2562 $revDirMap=$updater->getRevisionDirMap($sticky->{tag}); 2563 } 2564 2565 # Is it a directory? 2566 if( defined($revDirMap->{$fullPath}) || 2567 defined($otherRevDirMap->{$fullPath}) ) 2568 { 2569 $isDir=1; 2570 } 2571 } 2572 2573 # What to do with it? 2574 if(!$isDir) 2575 { 2576 $outNameMap->{$fullPath}=1; 2577 } 2578 else 2579 { 2580 $outDirMap->{$fullPath}=1; 2581 2582 if(defined($revDirMap->{$fullPath})) 2583 { 2584 addDirMapFiles($updater,$outNameMap,$outDirMap, 2585 $revDirMap->{$fullPath}); 2586 } 2587 if( defined($otherRevDirMap) && 2588 defined($otherRevDirMap->{$fullPath}) ) 2589 { 2590 addDirMapFiles($updater,$outNameMap,$outDirMap, 2591 $otherRevDirMap->{$fullPath}); 2592 } 2593 } 2594} 2595 2596# Used by argsfromdir 2597# Add entries from dirMap to outNameMap. Also recurse into entries 2598# that are subdirectories. 2599sub addDirMapFiles 2600{ 2601 my($updater,$outNameMap,$outDirMap,$dirMap)=@_; 2602 2603 my($fullName); 2604 foreach $fullName (keys(%$dirMap)) 2605 { 2606 my $cleanName=$fullName; 2607 if(defined($state->{prependdir})) 2608 { 2609 if(!($cleanName=~s/^\Q$state->{prependdir}\E//)) 2610 { 2611 $log->fatal("internal error stripping prependdir"); 2612 die "internal error stripping prependdir"; 2613 } 2614 } 2615 2616 if($dirMap->{$fullName} eq "F") 2617 { 2618 $outNameMap->{$cleanName}=1; 2619 } 2620 elsif($dirMap->{$fullName} eq "D") 2621 { 2622 if(!$state->{opt}{l}) 2623 { 2624 expandArg($updater,$outNameMap,$outDirMap,$cleanName,1); 2625 } 2626 } 2627 else 2628 { 2629 $log->fatal("internal error in addDirMapFiles"); 2630 die "internal error in addDirMapFiles"; 2631 } 2632 } 2633} 2634 2635# This method replaces $state->{args} with a directory-expanded 2636# list of all relevant filenames (recursively unless -d), based 2637# on $state->{entries}, and the "current" list of files in 2638# each directory. "Current" files as determined by 2639# either the requested (-r/-A) or "req_Sticky" version of 2640# that directory. 2641# Both the input args and the new output args are relative 2642# to the cvs-client's CWD, although some of the internal 2643# computations are relative to the top of the project. 2644sub argsfromdir 2645{ 2646 my $updater = shift; 2647 2648 # Notes about requirements for specific callers: 2649 # update # "standard" case (entries; a single -r/-A/default; -l) 2650 # # Special case: -d for create missing directories. 2651 # diff # 0 or 1 -r's: "standard" case. 2652 # # 2 -r's: We could ignore entries (just use the two -r's), 2653 # # but it doesn't really matter. 2654 # annotate # "standard" case 2655 # log # Punting: log -r has a more complex non-"standard" 2656 # # meaning, and we don't currently try to support log'ing 2657 # # branches at all (need a lot of work to 2658 # # support CVS-consistent branch relative version 2659 # # numbering). 2660#HERE: But we still want to expand directories. Maybe we should 2661# essentially force "-A". 2662 # status # "standard", except that -r/-A/default are not possible. 2663 # # Mostly only used to expand entries only) 2664 # 2665 # Don't use argsfromdir at all: 2666 # add # Explicit arguments required. Directory args imply add 2667 # # the directory itself, not the files in it. 2668 # co # Obtain list directly. 2669 # remove # HERE: TEST: MAYBE client does the recursion for us, 2670 # # since it only makes sense to remove stuff already in 2671 # # the sandbox? 2672 # ci # HERE: Similar to remove... 2673 # # Don't try to implement the confusing/weird 2674 # # ci -r bug er.."feature". 2675 2676 if(scalar(@{$state->{args}})==0) 2677 { 2678 $state->{args} = [ "." ]; 2679 } 2680 my %allArgs; 2681 my %allDirs; 2682 for my $file (@{$state->{args}}) 2683 { 2684 expandArg($updater,\%allArgs,\%allDirs,$file); 2685 } 2686 2687 # Include any entries from sandbox. Generally client won't 2688 # send entries that shouldn't be used. 2689 foreach my $file (keys %{$state->{entries}}) 2690 { 2691 $allArgs{remove_prependdir($file)} = 1; 2692 } 2693 2694 $state->{dirArgs} = \%allDirs; 2695 $state->{args} = [ 2696 sort { 2697 # Sort priority: by directory depth, then actual file name: 2698 my @piecesA=split('/',$a); 2699 my @piecesB=split('/',$b); 2700 2701 my $count=scalar(@piecesA); 2702 my $tmp=scalar(@piecesB); 2703 return $count<=>$tmp if($count!=$tmp); 2704 2705 for($tmp=0;$tmp<$count;$tmp++) 2706 { 2707 if($piecesA[$tmp] ne $piecesB[$tmp]) 2708 { 2709 return $piecesA[$tmp] cmp $piecesB[$tmp] 2710 } 2711 } 2712 return 0; 2713 } keys(%allArgs) ]; 2714} 2715 2716## look up directory sticky tag, of either fullPath or a parent: 2717sub getDirStickyInfo 2718{ 2719 my($fullPath)=@_; 2720 2721 $fullPath=~s%/+$%%; 2722 while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"})) 2723 { 2724 $fullPath=~s%/?[^/]*$%%; 2725 } 2726 2727 if( !defined($state->{dirMap}{"$fullPath/"}) && 2728 ( $fullPath eq "" || 2729 $fullPath eq "." ) ) 2730 { 2731 return $state->{dirMap}{""}{stickyInfo}; 2732 } 2733 else 2734 { 2735 return $state->{dirMap}{"$fullPath/"}{stickyInfo}; 2736 } 2737} 2738 2739# Resolve precedence of various ways of specifying which version of 2740# a file you want. Returns undef (for default head), or a ref to a hash 2741# that contains "tag" and/or "date" keys. 2742sub resolveStickyInfo 2743{ 2744 my($filename,$stickyTag,$stickyDate,$reset) = @_; 2745 2746 # Order of precedence of sticky tags: 2747 # -A [head] 2748 # -r /tag/ 2749 # [file entry sticky tag] 2750 # [the tag specified in dir req_Sticky] 2751 # [the tag specified in a parent dir req_Sticky] 2752 # [head] 2753 2754 my $result; 2755 if($reset) 2756 { 2757 # $result=undef; 2758 } 2759 elsif( defined($stickyTag) && $stickyTag ne "" ) 2760 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO 2761 { 2762 $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) }; 2763 2764 # TODO: Convert -D value into the form 2011.04.10.04.46.57, 2765 # similar to an entry line's sticky date, without the D prefix. 2766 # It sometimes (always?) arrives as something more like 2767 # '10 Apr 2011 04:46:57 -0000'... 2768 # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) }; 2769 } 2770 elsif( defined($state->{entries}{$filename}) && 2771 defined($state->{entries}{$filename}{tag_or_date}) && 2772 $state->{entries}{$filename}{tag_or_date} ne "" ) 2773 { 2774 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date}; 2775 if($tagOrDate=~/^T([^ ]+)\s*$/) 2776 { 2777 $result = { 'tag' => $1 }; 2778 } 2779 elsif($tagOrDate=~/^D([0-9.]+)\s*$/) 2780 { 2781 $result= { 'date' => $1 }; 2782 } 2783 else 2784 { 2785 die "Unknown tag_or_date format\n"; 2786 } 2787 } 2788 else 2789 { 2790 $result=getDirStickyInfo($filename); 2791 } 2792 2793 return $result; 2794} 2795 2796# Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into 2797# a form appropriate for the sticky tag field of an Entries 2798# line (field index 5, 0-based). 2799sub getStickyTagOrDate 2800{ 2801 my($stickyInfo)=@_; 2802 2803 my $result; 2804 if(defined($stickyInfo) && defined($stickyInfo->{tag})) 2805 { 2806 $result="T$stickyInfo->{tag}"; 2807 } 2808 # TODO: When/if we actually pick versions by {date} properly, 2809 # also handle it here: 2810 # "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07"). 2811 else 2812 { 2813 $result=""; 2814 } 2815 2816 return $result; 2817} 2818 2819# This method cleans up the $state variable after a command that uses arguments has run 2820sub statecleanup 2821{ 2822 $state->{files} = []; 2823 $state->{dirArgs} = {}; 2824 $state->{args} = []; 2825 $state->{arguments} = []; 2826 $state->{entries} = {}; 2827 $state->{dirMap} = {}; 2828} 2829 2830# Return working directory CVS revision "1.X" out 2831# of the working directory "entries" state, for the given filename. 2832# This is prefixed with a dash if the file is scheduled for removal 2833# when it is committed. 2834sub revparse 2835{ 2836 my $filename = shift; 2837 2838 return $state->{entries}{$filename}{revision}; 2839} 2840 2841# This method takes a file hash and does a CVS "file transfer". Its 2842# exact behaviour depends on a second, optional hash table argument: 2843# - If $options->{targetfile}, dump the contents to that file; 2844# - If $options->{print}, use M/MT to transmit the contents one line 2845# at a time; 2846# - Otherwise, transmit the size of the file, followed by the file 2847# contents. 2848sub transmitfile 2849{ 2850 my $filehash = shift; 2851 my $options = shift; 2852 2853 if ( defined ( $filehash ) and $filehash eq "deleted" ) 2854 { 2855 $log->warn("filehash is 'deleted'"); 2856 return; 2857 } 2858 2859 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ ); 2860 2861 my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash); 2862 chomp $type; 2863 2864 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" ); 2865 2866 my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash); 2867 chomp $size; 2868 2869 $log->debug("transmitfile($filehash) size=$size, type=$type"); 2870 2871 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash ) 2872 { 2873 if ( defined ( $options->{targetfile} ) ) 2874 { 2875 my $targetfile = $options->{targetfile}; 2876 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!"); 2877 print NEWFILE $_ while ( <$fh> ); 2878 close NEWFILE or die("Failed to write '$targetfile': $!"); 2879 } elsif ( defined ( $options->{print} ) && $options->{print} ) { 2880 while ( <$fh> ) { 2881 if( /\n\z/ ) { 2882 print 'M ', $_; 2883 } else { 2884 print 'MT text ', $_, "\n"; 2885 } 2886 } 2887 } else { 2888 print "$size\n"; 2889 print while ( <$fh> ); 2890 } 2891 close $fh or die ("Couldn't close filehandle for transmitfile(): $!"); 2892 } else { 2893 die("Couldn't execute git-cat-file"); 2894 } 2895} 2896 2897# This method takes a file name, and returns ( $dirpart, $filepart ) which 2898# refers to the directory portion and the file portion of the filename 2899# respectively 2900sub filenamesplit 2901{ 2902 my $filename = shift; 2903 my $fixforlocaldir = shift; 2904 2905 my ( $filepart, $dirpart ) = ( $filename, "." ); 2906 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ ); 2907 $dirpart .= "/"; 2908 2909 if ( $fixforlocaldir ) 2910 { 2911 $dirpart =~ s/^$state->{prependdir}//; 2912 } 2913 2914 return ( $filepart, $dirpart ); 2915} 2916 2917# Cleanup various junk in filename (try to canonicalize it), and 2918# add prependdir to accommodate running CVS client from a 2919# subdirectory (so the output is relative to top directory of the project). 2920sub filecleanup 2921{ 2922 my $filename = shift; 2923 2924 return undef unless(defined($filename)); 2925 if ( $filename =~ /^\// ) 2926 { 2927 print "E absolute filenames '$filename' not supported by server\n"; 2928 return undef; 2929 } 2930 2931 if($filename eq ".") 2932 { 2933 $filename=""; 2934 } 2935 $filename =~ s/^\.\///g; 2936 $filename =~ s%/+%/%g; 2937 $filename = $state->{prependdir} . $filename; 2938 $filename =~ s%/$%%; 2939 return $filename; 2940} 2941 2942# Remove prependdir from the path, so that it is relative to the directory 2943# the CVS client was started from, rather than the top of the project. 2944# Essentially the inverse of filecleanup(). 2945sub remove_prependdir 2946{ 2947 my($path) = @_; 2948 if(defined($state->{prependdir}) && $state->{prependdir} ne "") 2949 { 2950 my($pre)=$state->{prependdir}; 2951 $pre=~s%/$%%; 2952 if(!($path=~s%^\Q$pre\E/?%%)) 2953 { 2954 $log->fatal("internal error missing prependdir"); 2955 die("internal error missing prependdir"); 2956 } 2957 } 2958 return $path; 2959} 2960 2961sub validateGitDir 2962{ 2963 if( !defined($state->{CVSROOT}) ) 2964 { 2965 print "error 1 CVSROOT not specified\n"; 2966 cleanupWorkTree(); 2967 exit; 2968 } 2969 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') ) 2970 { 2971 print "error 1 Internally inconsistent CVSROOT\n"; 2972 cleanupWorkTree(); 2973 exit; 2974 } 2975} 2976 2977# Setup working directory in a work tree with the requested version 2978# loaded in the index. 2979sub setupWorkTree 2980{ 2981 my ($ver) = @_; 2982 2983 validateGitDir(); 2984 2985 if( ( defined($work->{state}) && $work->{state} != 1 ) || 2986 defined($work->{tmpDir}) ) 2987 { 2988 $log->warn("Bad work tree state management"); 2989 print "error 1 Internal setup multiple work trees without cleanup\n"; 2990 cleanupWorkTree(); 2991 exit; 2992 } 2993 2994 $work->{workDir} = tempdir ( DIR => $TEMP_DIR ); 2995 2996 if( !defined($work->{index}) ) 2997 { 2998 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 ); 2999 } 3000 3001 chdir $work->{workDir} or 3002 die "Unable to chdir to $work->{workDir}\n"; 3003 3004 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'"); 3005 3006 $ENV{GIT_WORK_TREE} = "."; 3007 $ENV{GIT_INDEX_FILE} = $work->{index}; 3008 $work->{state} = 2; 3009 3010 if($ver) 3011 { 3012 system("git","read-tree",$ver); 3013 unless ($? == 0) 3014 { 3015 $log->warn("Error running git-read-tree"); 3016 die "Error running git-read-tree $ver in $work->{workDir} $!\n"; 3017 } 3018 } 3019 # else # req_annotate reads tree for each file 3020} 3021 3022# Ensure current directory is in some kind of working directory, 3023# with a recent version loaded in the index. 3024sub ensureWorkTree 3025{ 3026 if( defined($work->{tmpDir}) ) 3027 { 3028 $log->warn("Bad work tree state management [ensureWorkTree()]"); 3029 print "error 1 Internal setup multiple dirs without cleanup\n"; 3030 cleanupWorkTree(); 3031 exit; 3032 } 3033 if( $work->{state} ) 3034 { 3035 return; 3036 } 3037 3038 validateGitDir(); 3039 3040 if( !defined($work->{emptyDir}) ) 3041 { 3042 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0); 3043 } 3044 chdir $work->{emptyDir} or 3045 die "Unable to chdir to $work->{emptyDir}\n"; 3046 3047 my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}"); 3048 chomp $ver; 3049 if ($ver !~ /^[0-9a-f]{$state->{hexsz}}$/) 3050 { 3051 $log->warn("Error from git show-ref -s refs/head$state->{module}"); 3052 print "error 1 cannot find the current HEAD of module"; 3053 cleanupWorkTree(); 3054 exit; 3055 } 3056 3057 if( !defined($work->{index}) ) 3058 { 3059 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 ); 3060 } 3061 3062 $ENV{GIT_WORK_TREE} = "."; 3063 $ENV{GIT_INDEX_FILE} = $work->{index}; 3064 $work->{state} = 1; 3065 3066 system("git","read-tree",$ver); 3067 unless ($? == 0) 3068 { 3069 die "Error running git-read-tree $ver $!\n"; 3070 } 3071} 3072 3073# Cleanup working directory that is not needed any longer. 3074sub cleanupWorkTree 3075{ 3076 if( ! $work->{state} ) 3077 { 3078 return; 3079 } 3080 3081 chdir "/" or die "Unable to chdir '/'\n"; 3082 3083 if( defined($work->{workDir}) ) 3084 { 3085 rmtree( $work->{workDir} ); 3086 undef $work->{workDir}; 3087 } 3088 undef $work->{state}; 3089} 3090 3091# Setup a temporary directory (not a working tree), typically for 3092# merging dirty state as in req_update. 3093sub setupTmpDir 3094{ 3095 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR ); 3096 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n"; 3097 3098 return $work->{tmpDir}; 3099} 3100 3101# Clean up a previously setupTmpDir. Restore previous work tree if 3102# appropriate. 3103sub cleanupTmpDir 3104{ 3105 if ( !defined($work->{tmpDir}) ) 3106 { 3107 $log->warn("cleanup tmpdir that has not been setup"); 3108 die "Cleanup tmpDir that has not been setup\n"; 3109 } 3110 if( defined($work->{state}) ) 3111 { 3112 if( $work->{state} == 1 ) 3113 { 3114 chdir $work->{emptyDir} or 3115 die "Unable to chdir to $work->{emptyDir}\n"; 3116 } 3117 elsif( $work->{state} == 2 ) 3118 { 3119 chdir $work->{workDir} or 3120 die "Unable to chdir to $work->{emptyDir}\n"; 3121 } 3122 else 3123 { 3124 $log->warn("Inconsistent work dir state"); 3125 die "Inconsistent work dir state\n"; 3126 } 3127 } 3128 else 3129 { 3130 chdir "/" or die "Unable to chdir '/'\n"; 3131 } 3132} 3133 3134# Given a path, this function returns a string containing the kopts 3135# that should go into that path's Entries line. For example, a binary 3136# file should get -kb. 3137sub kopts_from_path 3138{ 3139 my ($path, $srcType, $name) = @_; 3140 3141 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and 3142 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i ) 3143 { 3144 my ($val) = check_attr( "text", $path ); 3145 if ( $val eq "unspecified" ) 3146 { 3147 $val = check_attr( "crlf", $path ); 3148 } 3149 if ( $val eq "unset" ) 3150 { 3151 return "-kb" 3152 } 3153 elsif ( check_attr( "eol", $path ) ne "unspecified" || 3154 $val eq "set" || $val eq "input" ) 3155 { 3156 return ""; 3157 } 3158 else 3159 { 3160 $log->info("Unrecognized check_attr crlf $path : $val"); 3161 } 3162 } 3163 3164 if ( defined ( $cfg->{gitcvs}{allbinary} ) ) 3165 { 3166 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) ) 3167 { 3168 return "-kb"; 3169 } 3170 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) ) 3171 { 3172 if( is_binary($srcType,$name) ) 3173 { 3174 $log->debug("... as binary"); 3175 return "-kb"; 3176 } 3177 else 3178 { 3179 $log->debug("... as text"); 3180 } 3181 } 3182 } 3183 # Return "" to give no special treatment to any path 3184 return ""; 3185} 3186 3187sub check_attr 3188{ 3189 my ($attr,$path) = @_; 3190 ensureWorkTree(); 3191 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path ) 3192 { 3193 my $val = <$fh>; 3194 close $fh; 3195 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/; 3196 return $val; 3197 } 3198 else 3199 { 3200 return undef; 3201 } 3202} 3203 3204# This should have the same heuristics as convert.c:is_binary() and related. 3205# Note that the bare CR test is done by callers in convert.c. 3206sub is_binary 3207{ 3208 my ($srcType,$name) = @_; 3209 $log->debug("is_binary($srcType,$name)"); 3210 3211 # Minimize amount of interpreted code run in the inner per-character 3212 # loop for large files, by totalling each character value and 3213 # then analyzing the totals. 3214 my @counts; 3215 my $i; 3216 for($i=0;$i<256;$i++) 3217 { 3218 $counts[$i]=0; 3219 } 3220 3221 my $fh = open_blob_or_die($srcType,$name); 3222 my $line; 3223 while( defined($line=<$fh>) ) 3224 { 3225 # Any '\0' and bare CR are considered binary. 3226 if( $line =~ /\0|(\r[^\n])/ ) 3227 { 3228 close($fh); 3229 return 1; 3230 } 3231 3232 # Count up each character in the line: 3233 my $len=length($line); 3234 for($i=0;$i<$len;$i++) 3235 { 3236 $counts[ord(substr($line,$i,1))]++; 3237 } 3238 } 3239 close $fh; 3240 3241 # Don't count CR and LF as either printable/nonprintable 3242 $counts[ord("\n")]=0; 3243 $counts[ord("\r")]=0; 3244 3245 # Categorize individual character count into printable and nonprintable: 3246 my $printable=0; 3247 my $nonprintable=0; 3248 for($i=0;$i<256;$i++) 3249 { 3250 if( $i < 32 && 3251 $i != ord("\b") && 3252 $i != ord("\t") && 3253 $i != 033 && # ESC 3254 $i != 014 ) # FF 3255 { 3256 $nonprintable+=$counts[$i]; 3257 } 3258 elsif( $i==127 ) # DEL 3259 { 3260 $nonprintable+=$counts[$i]; 3261 } 3262 else 3263 { 3264 $printable+=$counts[$i]; 3265 } 3266 } 3267 3268 return ($printable >> 7) < $nonprintable; 3269} 3270 3271# Returns open file handle. Possible invocations: 3272# - open_blob_or_die("file",$filename); 3273# - open_blob_or_die("sha1",$filehash); 3274sub open_blob_or_die 3275{ 3276 my ($srcType,$name) = @_; 3277 my ($fh); 3278 if( $srcType eq "file" ) 3279 { 3280 if( !open $fh,"<",$name ) 3281 { 3282 $log->warn("Unable to open file $name: $!"); 3283 die "Unable to open file $name: $!\n"; 3284 } 3285 } 3286 elsif( $srcType eq "sha1" ) 3287 { 3288 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ ) 3289 { 3290 $log->warn("Need filehash"); 3291 die "Need filehash\n"; 3292 } 3293 3294 my $type = safe_pipe_capture('git', 'cat-file', '-t', $name); 3295 chomp $type; 3296 3297 unless ( defined ( $type ) and $type eq "blob" ) 3298 { 3299 $log->warn("Invalid type '$type' for '$name'"); 3300 die ( "Invalid type '$type' (expected 'blob')" ) 3301 } 3302 3303 my $size = safe_pipe_capture('git', 'cat-file', '-s', $name); 3304 chomp $size; 3305 3306 $log->debug("open_blob_or_die($name) size=$size, type=$type"); 3307 3308 unless( open $fh, '-|', "git", "cat-file", "blob", $name ) 3309 { 3310 $log->warn("Unable to open sha1 $name"); 3311 die "Unable to open sha1 $name\n"; 3312 } 3313 } 3314 else 3315 { 3316 $log->warn("Unknown type of blob source: $srcType"); 3317 die "Unknown type of blob source: $srcType\n"; 3318 } 3319 return $fh; 3320} 3321 3322# Generate a CVS author name from Git author information, by taking the local 3323# part of the email address and replacing characters not in the Portable 3324# Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS 3325# Login names are Unix login names, which should be restricted to this 3326# character set. 3327sub cvs_author 3328{ 3329 my $author_line = shift; 3330 (my $author) = $author_line =~ /<([^@>]*)/; 3331 3332 $author =~ s/[^-a-zA-Z0-9_.]/_/g; 3333 $author =~ s/^-/_/; 3334 3335 $author; 3336} 3337 3338 3339sub descramble 3340{ 3341 # This table is from src/scramble.c in the CVS source 3342 my @SHIFTS = ( 3343 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 3344 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 3345 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87, 3346 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105, 3347 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35, 3348 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56, 3349 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48, 3350 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223, 3351 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190, 3352 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193, 3353 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212, 3354 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246, 3355 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176, 3356 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127, 3357 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195, 3358 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152 3359 ); 3360 my ($str) = @_; 3361 3362 # This should never happen, the same password format (A) has been 3363 # used by CVS since the beginning of time 3364 { 3365 my $fmt = substr($str, 0, 1); 3366 die "invalid password format `$fmt'" unless $fmt eq 'A'; 3367 } 3368 3369 my @str = unpack "C*", substr($str, 1); 3370 my $ret = join '', map { chr $SHIFTS[$_] } @str; 3371 return $ret; 3372} 3373 3374# Test if the (deep) values of two references to a hash are the same. 3375sub refHashEqual 3376{ 3377 my($v1,$v2) = @_; 3378 3379 my $out; 3380 if(!defined($v1)) 3381 { 3382 if(!defined($v2)) 3383 { 3384 $out=1; 3385 } 3386 } 3387 elsif( !defined($v2) || 3388 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) ) 3389 { 3390 # $out=undef; 3391 } 3392 else 3393 { 3394 $out=1; 3395 3396 my $key; 3397 foreach $key (keys(%{$v1})) 3398 { 3399 if( !exists($v2->{$key}) || 3400 defined($v1->{$key}) ne defined($v2->{$key}) || 3401 ( defined($v1->{$key}) && 3402 $v1->{$key} ne $v2->{$key} ) ) 3403 { 3404 $out=undef; 3405 last; 3406 } 3407 } 3408 } 3409 3410 return $out; 3411} 3412 3413# an alternative to `command` that allows input to be passed as an array 3414# to work around shell problems with weird characters in arguments 3415 3416sub safe_pipe_capture { 3417 3418 my @output; 3419 3420 if (my $pid = open my $child, '-|') { 3421 @output = (<$child>); 3422 close $child or die join(' ',@_).": $! $?"; 3423 } else { 3424 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found 3425 } 3426 return wantarray ? @output : join('',@output); 3427} 3428 3429 3430package GITCVS::log; 3431 3432#### 3433#### Copyright The Open University UK - 2006. 3434#### 3435#### Authors: Martyn Smith <martyn@catalyst.net.nz> 3436#### Martin Langhoff <martin@laptop.org> 3437#### 3438#### 3439 3440use strict; 3441use warnings; 3442 3443=head1 NAME 3444 3445GITCVS::log 3446 3447=head1 DESCRIPTION 3448 3449This module provides very crude logging with a similar interface to 3450Log::Log4perl 3451 3452=head1 METHODS 3453 3454=cut 3455 3456=head2 new 3457 3458Creates a new log object, optionally you can specify a filename here to 3459indicate the file to log to. If no log file is specified, you can specify one 3460later with method setfile, or indicate you no longer want logging with method 3461nofile. 3462 3463Until one of these methods is called, all log calls will buffer messages ready 3464to write out. 3465 3466=cut 3467sub new 3468{ 3469 my $class = shift; 3470 my $filename = shift; 3471 3472 my $self = {}; 3473 3474 bless $self, $class; 3475 3476 if ( defined ( $filename ) ) 3477 { 3478 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!"); 3479 } 3480 3481 return $self; 3482} 3483 3484=head2 setfile 3485 3486This methods takes a filename, and attempts to open that file as the log file. 3487If successful, all buffered data is written out to the file, and any further 3488logging is written directly to the file. 3489 3490=cut 3491sub setfile 3492{ 3493 my $self = shift; 3494 my $filename = shift; 3495 3496 if ( defined ( $filename ) ) 3497 { 3498 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!"); 3499 } 3500 3501 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" ); 3502 3503 while ( my $line = shift @{$self->{buffer}} ) 3504 { 3505 print {$self->{fh}} $line; 3506 } 3507} 3508 3509=head2 nofile 3510 3511This method indicates no logging is going to be used. It flushes any entries in 3512the internal buffer, and sets a flag to ensure no further data is put there. 3513 3514=cut 3515sub nofile 3516{ 3517 my $self = shift; 3518 3519 $self->{nolog} = 1; 3520 3521 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" ); 3522 3523 $self->{buffer} = []; 3524} 3525 3526=head2 _logopen 3527 3528Internal method. Returns true if the log file is open, false otherwise. 3529 3530=cut 3531sub _logopen 3532{ 3533 my $self = shift; 3534 3535 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" ); 3536 return 0; 3537} 3538 3539=head2 debug info warn fatal 3540 3541These four methods are wrappers to _log. They provide the actual interface for 3542logging data. 3543 3544=cut 3545sub debug { my $self = shift; $self->_log("debug", @_); } 3546sub info { my $self = shift; $self->_log("info" , @_); } 3547sub warn { my $self = shift; $self->_log("warn" , @_); } 3548sub fatal { my $self = shift; $self->_log("fatal", @_); } 3549 3550=head2 _log 3551 3552This is an internal method called by the logging functions. It generates a 3553timestamp and pushes the logged line either to file, or internal buffer. 3554 3555=cut 3556sub _log 3557{ 3558 my $self = shift; 3559 my $level = shift; 3560 3561 return if ( $self->{nolog} ); 3562 3563 my @time = localtime; 3564 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s", 3565 $time[5] + 1900, 3566 $time[4] + 1, 3567 $time[3], 3568 $time[2], 3569 $time[1], 3570 $time[0], 3571 uc $level, 3572 ); 3573 3574 if ( $self->_logopen ) 3575 { 3576 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n"; 3577 } else { 3578 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n"; 3579 } 3580} 3581 3582=head2 DESTROY 3583 3584This method simply closes the file handle if one is open 3585 3586=cut 3587sub DESTROY 3588{ 3589 my $self = shift; 3590 3591 if ( $self->_logopen ) 3592 { 3593 close $self->{fh}; 3594 } 3595} 3596 3597package GITCVS::updater; 3598 3599#### 3600#### Copyright The Open University UK - 2006. 3601#### 3602#### Authors: Martyn Smith <martyn@catalyst.net.nz> 3603#### Martin Langhoff <martin@laptop.org> 3604#### 3605#### 3606 3607use strict; 3608use warnings; 3609use DBI; 3610 3611=head1 METHODS 3612 3613=cut 3614 3615=head2 new 3616 3617=cut 3618sub new 3619{ 3620 my $class = shift; 3621 my $config = shift; 3622 my $module = shift; 3623 my $log = shift; 3624 3625 die "Need to specify a git repository" unless ( defined($config) and -d $config ); 3626 die "Need to specify a module" unless ( defined($module) ); 3627 3628 $class = ref($class) || $class; 3629 3630 my $self = {}; 3631 3632 bless $self, $class; 3633 3634 $self->{valid_tables} = {'revision' => 1, 3635 'revision_ix1' => 1, 3636 'revision_ix2' => 1, 3637 'head' => 1, 3638 'head_ix1' => 1, 3639 'properties' => 1, 3640 'commitmsgs' => 1}; 3641 3642 $self->{module} = $module; 3643 $self->{git_path} = $config . "/"; 3644 3645 $self->{log} = $log; 3646 3647 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} ); 3648 3649 # Stores full sha1's for various branch/tag names, abbreviations, etc: 3650 $self->{commitRefCache} = {}; 3651 3652 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} || 3653 $cfg->{gitcvs}{dbdriver} || "SQLite"; 3654 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} || 3655 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite"; 3656 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} || 3657 $cfg->{gitcvs}{dbuser} || ""; 3658 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} || 3659 $cfg->{gitcvs}{dbpass} || ""; 3660 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} || 3661 $cfg->{gitcvs}{dbtablenameprefix} || ""; 3662 my %mapping = ( m => $module, 3663 a => $state->{method}, 3664 u => getlogin || getpwuid($<) || $<, 3665 G => $self->{git_path}, 3666 g => mangle_dirname($self->{git_path}), 3667 ); 3668 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg; 3669 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg; 3670 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg; 3671 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix}); 3672 3673 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/; 3674 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/; 3675 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}", 3676 $self->{dbuser}, 3677 $self->{dbpass}); 3678 die "Error connecting to database\n" unless defined $self->{dbh}; 3679 3680 $self->{tables} = {}; 3681 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} ) 3682 { 3683 $self->{tables}{$table} = 1; 3684 } 3685 3686 # Construct the revision table if required 3687 # The revision table stores an entry for each file, each time that file 3688 # changes. 3689 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit ) 3690 # This is not sufficient to support "-r {commithash}" for any 3691 # files except files that were modified by that commit (also, 3692 # some places in the code ignore/effectively strip out -r in 3693 # some cases, before it gets passed to getmeta()). 3694 # The "filehash" field typically has a git blob hash, but can also 3695 # be set to "dead" to indicate that the given version of the file 3696 # should not exist in the sandbox. 3697 unless ( $self->{tables}{$self->tablename("revision")} ) 3698 { 3699 my $tablename = $self->tablename("revision"); 3700 my $ix1name = $self->tablename("revision_ix1"); 3701 my $ix2name = $self->tablename("revision_ix2"); 3702 $self->{dbh}->do(" 3703 CREATE TABLE $tablename ( 3704 name TEXT NOT NULL, 3705 revision INTEGER NOT NULL, 3706 filehash TEXT NOT NULL, 3707 commithash TEXT NOT NULL, 3708 author TEXT NOT NULL, 3709 modified TEXT NOT NULL, 3710 mode TEXT NOT NULL 3711 ) 3712 "); 3713 $self->{dbh}->do(" 3714 CREATE INDEX $ix1name 3715 ON $tablename (name,revision) 3716 "); 3717 $self->{dbh}->do(" 3718 CREATE INDEX $ix2name 3719 ON $tablename (name,commithash) 3720 "); 3721 } 3722 3723 # Construct the head table if required 3724 # The head table (along with the "last_commit" entry in the property 3725 # table) is the persisted working state of the "sub update" subroutine. 3726 # All of it's data is read entirely first, and completely recreated 3727 # last, every time "sub update" runs. 3728 # This is also used by "sub getmeta" when it is asked for the latest 3729 # version of a file (as opposed to some specific version). 3730 # Another way of thinking about it is as a single slice out of 3731 # "revisions", giving just the most recent revision information for 3732 # each file. 3733 unless ( $self->{tables}{$self->tablename("head")} ) 3734 { 3735 my $tablename = $self->tablename("head"); 3736 my $ix1name = $self->tablename("head_ix1"); 3737 $self->{dbh}->do(" 3738 CREATE TABLE $tablename ( 3739 name TEXT NOT NULL, 3740 revision INTEGER NOT NULL, 3741 filehash TEXT NOT NULL, 3742 commithash TEXT NOT NULL, 3743 author TEXT NOT NULL, 3744 modified TEXT NOT NULL, 3745 mode TEXT NOT NULL 3746 ) 3747 "); 3748 $self->{dbh}->do(" 3749 CREATE INDEX $ix1name 3750 ON $tablename (name) 3751 "); 3752 } 3753 3754 # Construct the properties table if required 3755 # - "last_commit" - Used by "sub update". 3756 unless ( $self->{tables}{$self->tablename("properties")} ) 3757 { 3758 my $tablename = $self->tablename("properties"); 3759 $self->{dbh}->do(" 3760 CREATE TABLE $tablename ( 3761 key TEXT NOT NULL PRIMARY KEY, 3762 value TEXT 3763 ) 3764 "); 3765 } 3766 3767 # Construct the commitmsgs table if required 3768 # The commitmsgs table is only used for merge commits, since 3769 # "sub update" will only keep one branch of parents. Shortlogs 3770 # for ignored commits (i.e. not on the chosen branch) will be used 3771 # to construct a replacement "collapsed" merge commit message, 3772 # which will be stored in this table. See also "sub commitmessage". 3773 unless ( $self->{tables}{$self->tablename("commitmsgs")} ) 3774 { 3775 my $tablename = $self->tablename("commitmsgs"); 3776 $self->{dbh}->do(" 3777 CREATE TABLE $tablename ( 3778 key TEXT NOT NULL PRIMARY KEY, 3779 value TEXT 3780 ) 3781 "); 3782 } 3783 3784 return $self; 3785} 3786 3787=head2 tablename 3788 3789=cut 3790sub tablename 3791{ 3792 my $self = shift; 3793 my $name = shift; 3794 3795 if (exists $self->{valid_tables}{$name}) { 3796 return $self->{dbtablenameprefix} . $name; 3797 } else { 3798 return undef; 3799 } 3800} 3801 3802=head2 update 3803 3804Bring the database up to date with the latest changes from 3805the git repository. 3806 3807Internal working state is read out of the "head" table and the 3808"last_commit" property, then it updates "revisions" based on that, and 3809finally it writes the new internal state back to the "head" table 3810so it can be used as a starting point the next time update is called. 3811 3812=cut 3813sub update 3814{ 3815 my $self = shift; 3816 3817 # first lets get the commit list 3818 $ENV{GIT_DIR} = $self->{git_path}; 3819 3820 my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module}); 3821 chomp $commitsha1; 3822 3823 my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module}); 3824 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ ) 3825 { 3826 die("Invalid module '$self->{module}'"); 3827 } 3828 3829 3830 my $git_log; 3831 my $lastcommit = $self->_get_prop("last_commit"); 3832 3833 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date 3834 # invalidate the gethead cache 3835 $self->clearCommitRefCaches(); 3836 return 1; 3837 } 3838 3839 # Start exclusive lock here... 3840 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN"; 3841 3842 # TODO: log processing is memory bound 3843 # if we can parse into a 2nd file that is in reverse order 3844 # we can probably do something really efficient 3845 my @git_log_params = ('--pretty', '--parents', '--topo-order'); 3846 3847 if (defined $lastcommit) { 3848 push @git_log_params, "$lastcommit..$self->{module}"; 3849 } else { 3850 push @git_log_params, $self->{module}; 3851 } 3852 # git-rev-list is the backend / plumbing version of git-log 3853 open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params) 3854 or die "Cannot call git-rev-list: $!"; 3855 my @commits=readCommits($gitLogPipe); 3856 close $gitLogPipe; 3857 3858 # Now all the commits are in the @commits bucket 3859 # ordered by time DESC. for each commit that needs processing, 3860 # determine whether it's following the last head we've seen or if 3861 # it's on its own branch, grab a file list, and add whatever's changed 3862 # NOTE: $lastcommit refers to the last commit from previous run 3863 # $lastpicked is the last commit we picked in this run 3864 my $lastpicked; 3865 my $head = {}; 3866 if (defined $lastcommit) { 3867 $lastpicked = $lastcommit; 3868 } 3869 3870 my $committotal = scalar(@commits); 3871 my $commitcount = 0; 3872 3873 # Load the head table into $head (for cached lookups during the update process) 3874 foreach my $file ( @{$self->gethead(1)} ) 3875 { 3876 $head->{$file->{name}} = $file; 3877 } 3878 3879 foreach my $commit ( @commits ) 3880 { 3881 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)"); 3882 if (defined $lastpicked) 3883 { 3884 if (!in_array($lastpicked, @{$commit->{parents}})) 3885 { 3886 # skip, we'll see this delta 3887 # as part of a merge later 3888 # warn "skipping off-track $commit->{hash}\n"; 3889 next; 3890 } elsif (@{$commit->{parents}} > 1) { 3891 # it is a merge commit, for each parent that is 3892 # not $lastpicked (not given a CVS revision number), 3893 # see if we can get a log 3894 # from the merge-base to that parent to put it 3895 # in the message as a merge summary. 3896 my @parents = @{$commit->{parents}}; 3897 foreach my $parent (@parents) { 3898 if ($parent eq $lastpicked) { 3899 next; 3900 } 3901 # git-merge-base can potentially (but rarely) throw 3902 # several candidate merge bases. let's assume 3903 # that the first one is the best one. 3904 my $base = eval { 3905 ::safe_pipe_capture('git', 'merge-base', 3906 $lastpicked, $parent); 3907 }; 3908 # The two branches may not be related at all, 3909 # in which case merge base simply fails to find 3910 # any, but that's Ok. 3911 next if ($@); 3912 3913 chomp $base; 3914 if ($base) { 3915 my @merged; 3916 # print "want to log between $base $parent \n"; 3917 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent") 3918 or die "Cannot call git-log: $!"; 3919 my $mergedhash; 3920 while (<GITLOG>) { 3921 chomp; 3922 if (!defined $mergedhash) { 3923 if (m/^commit\s+(.+)$/) { 3924 $mergedhash = $1; 3925 } else { 3926 next; 3927 } 3928 } else { 3929 # grab the first line that looks non-rfc822 3930 # aka has content after leading space 3931 if (m/^\s+(\S.*)$/) { 3932 my $title = $1; 3933 $title = substr($title,0,100); # truncate 3934 unshift @merged, "$mergedhash $title"; 3935 undef $mergedhash; 3936 } 3937 } 3938 } 3939 close GITLOG; 3940 if (@merged) { 3941 $commit->{mergemsg} = $commit->{message}; 3942 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n"; 3943 foreach my $summary (@merged) { 3944 $commit->{mergemsg} .= "\t$summary\n"; 3945 } 3946 $commit->{mergemsg} .= "\n\n"; 3947 # print "Message for $commit->{hash} \n$commit->{mergemsg}"; 3948 } 3949 } 3950 } 3951 } 3952 } 3953 3954 # convert the date to CVS-happy format 3955 my $cvsDate = convertToCvsDate($commit->{date}); 3956 3957 if ( defined ( $lastpicked ) ) 3958 { 3959 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!"); 3960 local ($/) = "\0"; 3961 while ( <FILELIST> ) 3962 { 3963 chomp; 3964 unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o ) 3965 { 3966 die("Couldn't process git-diff-tree line : $_"); 3967 } 3968 my ($mode, $hash, $change) = ($1, $2, $3); 3969 my $name = <FILELIST>; 3970 chomp($name); 3971 3972 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name"); 3973 3974 my $dbMode = convertToDbMode($mode); 3975 3976 if ( $change eq "D" ) 3977 { 3978 #$log->debug("DELETE $name"); 3979 $head->{$name} = { 3980 name => $name, 3981 revision => $head->{$name}{revision} + 1, 3982 filehash => "deleted", 3983 commithash => $commit->{hash}, 3984 modified => $cvsDate, 3985 author => $commit->{author}, 3986 mode => $dbMode, 3987 }; 3988 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode); 3989 } 3990 elsif ( $change eq "M" || $change eq "T" ) 3991 { 3992 #$log->debug("MODIFIED $name"); 3993 $head->{$name} = { 3994 name => $name, 3995 revision => $head->{$name}{revision} + 1, 3996 filehash => $hash, 3997 commithash => $commit->{hash}, 3998 modified => $cvsDate, 3999 author => $commit->{author}, 4000 mode => $dbMode, 4001 }; 4002 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode); 4003 } 4004 elsif ( $change eq "A" ) 4005 { 4006 #$log->debug("ADDED $name"); 4007 $head->{$name} = { 4008 name => $name, 4009 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1, 4010 filehash => $hash, 4011 commithash => $commit->{hash}, 4012 modified => $cvsDate, 4013 author => $commit->{author}, 4014 mode => $dbMode, 4015 }; 4016 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode); 4017 } 4018 else 4019 { 4020 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name"); 4021 die; 4022 } 4023 } 4024 close FILELIST; 4025 } else { 4026 # this is used to detect files removed from the repo 4027 my $seen_files = {}; 4028 4029 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!"); 4030 local $/ = "\0"; 4031 while ( <FILELIST> ) 4032 { 4033 chomp; 4034 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o ) 4035 { 4036 die("Couldn't process git-ls-tree line : $_"); 4037 } 4038 4039 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 ); 4040 4041 $seen_files->{$git_filename} = 1; 4042 4043 my ( $oldhash, $oldrevision, $oldmode ) = ( 4044 $head->{$git_filename}{filehash}, 4045 $head->{$git_filename}{revision}, 4046 $head->{$git_filename}{mode} 4047 ); 4048 4049 my $dbMode = convertToDbMode($mode); 4050 4051 # unless the file exists with the same hash, we need to update it ... 4052 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode ) 4053 { 4054 my $newrevision = ( $oldrevision or 0 ) + 1; 4055 4056 $head->{$git_filename} = { 4057 name => $git_filename, 4058 revision => $newrevision, 4059 filehash => $git_hash, 4060 commithash => $commit->{hash}, 4061 modified => $cvsDate, 4062 author => $commit->{author}, 4063 mode => $dbMode, 4064 }; 4065 4066 4067 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode); 4068 } 4069 } 4070 close FILELIST; 4071 4072 # Detect deleted files 4073 foreach my $file ( sort keys %$head ) 4074 { 4075 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" ) 4076 { 4077 $head->{$file}{revision}++; 4078 $head->{$file}{filehash} = "deleted"; 4079 $head->{$file}{commithash} = $commit->{hash}; 4080 $head->{$file}{modified} = $cvsDate; 4081 $head->{$file}{author} = $commit->{author}; 4082 4083 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode}); 4084 } 4085 } 4086 # END : "Detect deleted files" 4087 } 4088 4089 4090 if (exists $commit->{mergemsg}) 4091 { 4092 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg}); 4093 } 4094 4095 $lastpicked = $commit->{hash}; 4096 4097 $self->_set_prop("last_commit", $commit->{hash}); 4098 } 4099 4100 $self->delete_head(); 4101 foreach my $file ( sort keys %$head ) 4102 { 4103 $self->insert_head( 4104 $file, 4105 $head->{$file}{revision}, 4106 $head->{$file}{filehash}, 4107 $head->{$file}{commithash}, 4108 $head->{$file}{modified}, 4109 $head->{$file}{author}, 4110 $head->{$file}{mode}, 4111 ); 4112 } 4113 # invalidate the gethead cache 4114 $self->clearCommitRefCaches(); 4115 4116 4117 # Ending exclusive lock here 4118 $self->{dbh}->commit() or die "Failed to commit changes to SQLite"; 4119} 4120 4121sub readCommits 4122{ 4123 my $pipeHandle = shift; 4124 my @commits; 4125 4126 my %commit = (); 4127 4128 while ( <$pipeHandle> ) 4129 { 4130 chomp; 4131 if (m/^commit\s+(.*)$/) { 4132 # on ^commit lines put the just seen commit in the stack 4133 # and prime things for the next one 4134 if (keys %commit) { 4135 my %copy = %commit; 4136 unshift @commits, \%copy; 4137 %commit = (); 4138 } 4139 my @parents = split(m/\s+/, $1); 4140 $commit{hash} = shift @parents; 4141 $commit{parents} = \@parents; 4142 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) { 4143 # on rfc822-like lines seen before we see any message, 4144 # lowercase the entry and put it in the hash as key-value 4145 $commit{lc($1)} = $2; 4146 } else { 4147 # message lines - skip initial empty line 4148 # and trim whitespace 4149 if (!exists($commit{message}) && m/^\s*$/) { 4150 # define it to mark the end of headers 4151 $commit{message} = ''; 4152 next; 4153 } 4154 s/^\s+//; s/\s+$//; # trim ws 4155 $commit{message} .= $_ . "\n"; 4156 } 4157 } 4158 4159 unshift @commits, \%commit if ( keys %commit ); 4160 4161 return @commits; 4162} 4163 4164sub convertToCvsDate 4165{ 4166 my $date = shift; 4167 # Convert from: "git rev-list --pretty" formatted date 4168 # Convert to: "the format specified by RFC822 as modified by RFC1123." 4169 # Example: 26 May 1997 13:01:40 -0400 4170 if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ ) 4171 { 4172 $date = "$2 $1 $4 $3 $5"; 4173 } 4174 4175 return $date; 4176} 4177 4178sub convertToDbMode 4179{ 4180 my $mode = shift; 4181 4182 # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw", 4183 # but the database "mode" column historically (and currently) 4184 # only stores the "rw" (for user) part of the string. 4185 # FUTURE: It might make more sense to persist the raw 4186 # octal mode (or perhaps the final full CVS form) instead of 4187 # this half-converted form, but it isn't currently worth the 4188 # backwards compatibility headaches. 4189 4190 $mode=~/^\d{3}(\d)\d\d$/; 4191 my $userBits=$1; 4192 4193 my $dbMode = ""; 4194 $dbMode .= "r" if ( $userBits & 4 ); 4195 $dbMode .= "w" if ( $userBits & 2 ); 4196 $dbMode .= "x" if ( $userBits & 1 ); 4197 $dbMode = "rw" if ( $dbMode eq "" ); 4198 4199 return $dbMode; 4200} 4201 4202sub insert_rev 4203{ 4204 my $self = shift; 4205 my $name = shift; 4206 my $revision = shift; 4207 my $filehash = shift; 4208 my $commithash = shift; 4209 my $modified = shift; 4210 my $author = shift; 4211 my $mode = shift; 4212 my $tablename = $self->tablename("revision"); 4213 4214 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1); 4215 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode); 4216} 4217 4218sub insert_mergelog 4219{ 4220 my $self = shift; 4221 my $key = shift; 4222 my $value = shift; 4223 my $tablename = $self->tablename("commitmsgs"); 4224 4225 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1); 4226 $insert_mergelog->execute($key, $value); 4227} 4228 4229sub delete_head 4230{ 4231 my $self = shift; 4232 my $tablename = $self->tablename("head"); 4233 4234 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1); 4235 $delete_head->execute(); 4236} 4237 4238sub insert_head 4239{ 4240 my $self = shift; 4241 my $name = shift; 4242 my $revision = shift; 4243 my $filehash = shift; 4244 my $commithash = shift; 4245 my $modified = shift; 4246 my $author = shift; 4247 my $mode = shift; 4248 my $tablename = $self->tablename("head"); 4249 4250 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1); 4251 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode); 4252} 4253 4254sub _get_prop 4255{ 4256 my $self = shift; 4257 my $key = shift; 4258 my $tablename = $self->tablename("properties"); 4259 4260 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1); 4261 $db_query->execute($key); 4262 my ( $value ) = $db_query->fetchrow_array; 4263 4264 return $value; 4265} 4266 4267sub _set_prop 4268{ 4269 my $self = shift; 4270 my $key = shift; 4271 my $value = shift; 4272 my $tablename = $self->tablename("properties"); 4273 4274 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1); 4275 $db_query->execute($value, $key); 4276 4277 unless ( $db_query->rows ) 4278 { 4279 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1); 4280 $db_query->execute($key, $value); 4281 } 4282 4283 return $value; 4284} 4285 4286=head2 gethead 4287 4288=cut 4289 4290sub gethead 4291{ 4292 my $self = shift; 4293 my $intRev = shift; 4294 my $tablename = $self->tablename("head"); 4295 4296 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) ); 4297 4298 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1); 4299 $db_query->execute(); 4300 4301 my $tree = []; 4302 while ( my $file = $db_query->fetchrow_hashref ) 4303 { 4304 if(!$intRev) 4305 { 4306 $file->{revision} = "1.$file->{revision}" 4307 } 4308 push @$tree, $file; 4309 } 4310 4311 $self->{gethead_cache} = $tree; 4312 4313 return $tree; 4314} 4315 4316=head2 getAnyHead 4317 4318Returns a reference to an array of getmeta structures, one 4319per file in the specified tree hash. 4320 4321=cut 4322 4323sub getAnyHead 4324{ 4325 my ($self,$hash) = @_; 4326 4327 if(!defined($hash)) 4328 { 4329 return $self->gethead(); 4330 } 4331 4332 my @files; 4333 { 4334 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash) 4335 or die("Cannot call git-ls-tree : $!"); 4336 local $/ = "\0"; 4337 @files=<$filePipe>; 4338 close $filePipe; 4339 } 4340 4341 my $tree=[]; 4342 my($line); 4343 foreach $line (@files) 4344 { 4345 $line=~s/\0$//; 4346 unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o ) 4347 { 4348 die("Couldn't process git-ls-tree line : $_"); 4349 } 4350 4351 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4); 4352 push @$tree, $self->getMetaFromCommithash($git_filename,$hash); 4353 } 4354 4355 return $tree; 4356} 4357 4358=head2 getRevisionDirMap 4359 4360A "revision dir map" contains all the plain-file filenames associated 4361with a particular revision (tree-ish), organized by directory: 4362 4363 $type = $out->{$dir}{$fullName} 4364 4365The type of each is "F" (for ordinary file) or "D" (for directory, 4366for which the map $out->{$fullName} will also exist). 4367 4368=cut 4369 4370sub getRevisionDirMap 4371{ 4372 my ($self,$ver)=@_; 4373 4374 if(!defined($self->{revisionDirMapCache})) 4375 { 4376 $self->{revisionDirMapCache}={}; 4377 } 4378 4379 # Get file list (previously cached results are dependent on HEAD, 4380 # but are early in each case): 4381 my $cacheKey; 4382 my (@fileList); 4383 if( !defined($ver) || $ver eq "" ) 4384 { 4385 $cacheKey=""; 4386 if( defined($self->{revisionDirMapCache}{$cacheKey}) ) 4387 { 4388 return $self->{revisionDirMapCache}{$cacheKey}; 4389 } 4390 4391 my @head = @{$self->gethead()}; 4392 foreach my $file ( @head ) 4393 { 4394 next if ( $file->{filehash} eq "deleted" ); 4395 4396 push @fileList,$file->{name}; 4397 } 4398 } 4399 else 4400 { 4401 my ($hash)=$self->lookupCommitRef($ver); 4402 if( !defined($hash) ) 4403 { 4404 return undef; 4405 } 4406 4407 $cacheKey=$hash; 4408 if( defined($self->{revisionDirMapCache}{$cacheKey}) ) 4409 { 4410 return $self->{revisionDirMapCache}{$cacheKey}; 4411 } 4412 4413 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash) 4414 or die("Cannot call git-ls-tree : $!"); 4415 local $/ = "\0"; 4416 while ( <$filePipe> ) 4417 { 4418 chomp; 4419 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o ) 4420 { 4421 die("Couldn't process git-ls-tree line : $_"); 4422 } 4423 4424 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4); 4425 4426 push @fileList, $git_filename; 4427 } 4428 close $filePipe; 4429 } 4430 4431 # Convert to normalized form: 4432 my %revMap; 4433 my $file; 4434 foreach $file (@fileList) 4435 { 4436 my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%); 4437 $dir='' if(!defined($dir)); 4438 4439 # parent directories: 4440 # ... create empty dir maps for parent dirs: 4441 my($td)=$dir; 4442 while(!defined($revMap{$td})) 4443 { 4444 $revMap{$td}={}; 4445 4446 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%); 4447 $tp='' if(!defined($tp)); 4448 $td=$tp; 4449 } 4450 # ... add children to parent maps (now that they exist): 4451 $td=$dir; 4452 while($td ne "") 4453 { 4454 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%); 4455 $tp='' if(!defined($tp)); 4456 4457 if(defined($revMap{$tp}{$td})) 4458 { 4459 if($revMap{$tp}{$td} ne 'D') 4460 { 4461 die "Weird file/directory inconsistency in $cacheKey"; 4462 } 4463 last; # loop exit 4464 } 4465 $revMap{$tp}{$td}='D'; 4466 4467 $td=$tp; 4468 } 4469 4470 # file 4471 $revMap{$dir}{$file}='F'; 4472 } 4473 4474 # Save in cache: 4475 $self->{revisionDirMapCache}{$cacheKey}=\%revMap; 4476 return $self->{revisionDirMapCache}{$cacheKey}; 4477} 4478 4479=head2 getlog 4480 4481See also gethistorydense(). 4482 4483=cut 4484 4485sub getlog 4486{ 4487 my $self = shift; 4488 my $filename = shift; 4489 my $revFilter = shift; 4490 4491 my $tablename = $self->tablename("revision"); 4492 4493 # Filters: 4494 # TODO: date, state, or by specific logins filters? 4495 # TODO: Handle comma-separated list of revFilter items, each item 4496 # can be a range [only case currently handled] or individual 4497 # rev or branch or "branch.". 4498 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of 4499 # manually filtering the results of the query? 4500 my ( $minrev, $maxrev ); 4501 if( defined($revFilter) and 4502 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ ) 4503 { 4504 my $control = $3; 4505 $minrev = $2; 4506 $maxrev = $5; 4507 $minrev++ if ( defined($minrev) and $control eq "::" ); 4508 } 4509 4510 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1); 4511 $db_query->execute($filename); 4512 4513 my $totalRevs=0; 4514 my $tree = []; 4515 while ( my $file = $db_query->fetchrow_hashref ) 4516 { 4517 $totalRevs++; 4518 if( defined($minrev) and $file->{revision} < $minrev ) 4519 { 4520 next; 4521 } 4522 if( defined($maxrev) and $file->{revision} > $maxrev ) 4523 { 4524 next; 4525 } 4526 4527 $file->{revision} = "1." . $file->{revision}; 4528 push @$tree, $file; 4529 } 4530 4531 return ($tree,$totalRevs); 4532} 4533 4534=head2 getmeta 4535 4536This function takes a filename (with path) argument and returns a hashref of 4537metadata for that file. 4538 4539There are several ways $revision can be specified: 4540 4541 - A reference to hash that contains a "tag" that is the 4542 actual revision (one of the below). TODO: Also allow it to 4543 specify a "date" in the hash. 4544 - undef, to refer to the latest version on the main branch. 4545 - Full CVS client revision number (mapped to integer in DB, without the 4546 "1." prefix), 4547 - Complex CVS-compatible "special" revision number for 4548 non-linear history (see comment below) 4549 - git commit sha1 hash 4550 - branch or tag name 4551 4552=cut 4553 4554sub getmeta 4555{ 4556 my $self = shift; 4557 my $filename = shift; 4558 my $revision = shift; 4559 my $tablename_rev = $self->tablename("revision"); 4560 my $tablename_head = $self->tablename("head"); 4561 4562 if ( ref($revision) eq "HASH" ) 4563 { 4564 $revision = $revision->{tag}; 4565 } 4566 4567 # Overview of CVS revision numbers: 4568 # 4569 # General CVS numbering scheme: 4570 # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc. 4571 # - Result of "cvs checkin -r" (possible, but not really 4572 # recommended): "2.1", "2.2", etc 4573 # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched 4574 # from, "0" is a magic placeholder that identifies it as a 4575 # branch tag instead of a version tag, and n is 2 times the 4576 # branch number off of "1.2", starting with "2". 4577 # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n" 4578 # is branch number off of "1.2" (like n above), and "x" is 4579 # the version number on the branch. 4580 # - Branches can branch off of branches: "1.3.2.7.4.1" (even number 4581 # of components). 4582 # - Odd "n"s are used by "vendor branches" that result 4583 # from "cvs import". Vendor branches have additional 4584 # strangeness in the sense that the main rcs "head" of the main 4585 # branch will (temporarily until first normal commit) point 4586 # to the version on the vendor branch, rather than the actual 4587 # main branch. (FUTURE: This may provide an opportunity 4588 # to use "strange" revision numbers for fast-forward-merged 4589 # branch tip when CVS client is asking for the main branch.) 4590 # 4591 # git-cvsserver CVS-compatible special numbering schemes: 4592 # - Currently git-cvsserver only tries to be identical to CVS for 4593 # simple "1.x" numbers on the "main" branch (as identified 4594 # by the module name that was originally cvs checkout'ed). 4595 # - The database only stores the "x" part, for historical reasons. 4596 # But most of the rest of the cvsserver preserves 4597 # and thinks using the full revision number. 4598 # - To handle non-linear history, it uses a version of the form 4599 # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely 4600 # identify this as a special revision number, and there are 4601 # 20 b's that together encode the sha1 git commit from which 4602 # this version of this file originated. Each b is 4603 # the numerical value of the corresponding byte plus 4604 # 100. 4605 # - "plus 100" avoids "0"s, and also reduces the 4606 # likelihood of a collision in the case that someone someday 4607 # writes an import tool that tries to preserve original 4608 # CVS revision numbers, and the original CVS data had done 4609 # lots of branches off of branches and other strangeness to 4610 # end up with a real version number that just happens to look 4611 # like this special revision number form. Also, if needed 4612 # there are several ways to extend/identify alternative encodings 4613 # within the "2.1.1.2000" part if necessary. 4614 # - Unlike real CVS revisions, you can't really reconstruct what 4615 # relation a revision of this form has to other revisions. 4616 # - FUTURE: TODO: Rework database somehow to make up and remember 4617 # fully-CVS-compatible branches and branch version numbers. 4618 4619 my $meta; 4620 if ( defined($revision) ) 4621 { 4622 if ( $revision =~ /^1\.(\d+)$/ ) 4623 { 4624 my ($intRev) = $1; 4625 my $db_query; 4626 $db_query = $self->{dbh}->prepare_cached( 4627 "SELECT * FROM $tablename_rev WHERE name=? AND revision=?", 4628 {},1); 4629 $db_query->execute($filename, $intRev); 4630 $meta = $db_query->fetchrow_hashref; 4631 } 4632 elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ ) 4633 { 4634 my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/); 4635 $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg; 4636 if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/) 4637 { 4638 return $self->getMetaFromCommithash($filename,$commitHash); 4639 } 4640 4641 # error recovery: fall back on head version below 4642 print "E Failed to find $filename version=$revision or commit=$commitHash\n"; 4643 $log->warning("failed get $revision with commithash=$commitHash"); 4644 undef $revision; 4645 } 4646 elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ ) 4647 { 4648 # Try DB first. This is mostly only useful for req_annotate(), 4649 # which only calls this for stuff that should already be in 4650 # the DB. It is fairly likely to be a waste of time 4651 # in most other cases [unless the file happened to be 4652 # modified in $revision specifically], but 4653 # it is probably in the noise compared to how long 4654 # getMetaFromCommithash() will take. 4655 my $db_query; 4656 $db_query = $self->{dbh}->prepare_cached( 4657 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?", 4658 {},1); 4659 $db_query->execute($filename, $revision); 4660 $meta = $db_query->fetchrow_hashref; 4661 4662 if(! $meta) 4663 { 4664 my($revCommit)=$self->lookupCommitRef($revision); 4665 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/) 4666 { 4667 return $self->getMetaFromCommithash($filename,$revCommit); 4668 } 4669 4670 # error recovery: nothing found: 4671 print "E Failed to find $filename version=$revision\n"; 4672 $log->warning("failed get $revision"); 4673 return $meta; 4674 } 4675 } 4676 else 4677 { 4678 my($revCommit)=$self->lookupCommitRef($revision); 4679 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/) 4680 { 4681 return $self->getMetaFromCommithash($filename,$revCommit); 4682 } 4683 4684 # error recovery: fall back on head version below 4685 print "E Failed to find $filename version=$revision\n"; 4686 $log->warning("failed get $revision"); 4687 undef $revision; # Allow fallback 4688 } 4689 } 4690 4691 if(!defined($revision)) 4692 { 4693 my $db_query; 4694 $db_query = $self->{dbh}->prepare_cached( 4695 "SELECT * FROM $tablename_head WHERE name=?",{},1); 4696 $db_query->execute($filename); 4697 $meta = $db_query->fetchrow_hashref; 4698 } 4699 4700 if($meta) 4701 { 4702 $meta->{revision} = "1.$meta->{revision}"; 4703 } 4704 return $meta; 4705} 4706 4707sub getMetaFromCommithash 4708{ 4709 my $self = shift; 4710 my $filename = shift; 4711 my $revCommit = shift; 4712 4713 # NOTE: This function doesn't scale well (lots of forks), especially 4714 # if you have many files that have not been modified for many commits 4715 # (each git-rev-parse redoes a lot of work for each file 4716 # that theoretically could be done in parallel by smarter 4717 # graph traversal). 4718 # 4719 # TODO: Possible optimization strategies: 4720 # - Solve the issue of assigning and remembering "real" CVS 4721 # revision numbers for branches, and ensure the 4722 # data structure can do this efficiently. Perhaps something 4723 # similar to "git notes", and carefully structured to take 4724 # advantage same-sha1-is-same-contents, to roll the same 4725 # unmodified subdirectory data onto multiple commits? 4726 # - Write and use a C tool that is like git-blame, but 4727 # operates on multiple files with file granularity, instead 4728 # of one file with line granularity. Cache 4729 # most-recently-modified in $self->{commitRefCache}{$revCommit}. 4730 # Try to be intelligent about how many files we do with 4731 # one fork (perhaps one directory at a time, without recursion, 4732 # and/or include directory as one line item, recurse from here 4733 # instead of in C tool?). 4734 # - Perhaps we could ask the DB for (filename,fileHash), 4735 # and just guess that it is correct (that the file hadn't 4736 # changed between $revCommit and the found commit, then 4737 # changed back, confusing anything trying to interpret 4738 # history). Probably need to add another index to revisions 4739 # DB table for this. 4740 # - NOTE: Trying to store all (commit,file) keys in DB [to 4741 # find "lastModfiedCommit] (instead of 4742 # just files that changed in each commit as we do now) is 4743 # probably not practical from a disk space perspective. 4744 4745 # Does the file exist in $revCommit? 4746 # TODO: Include file hash in dirmap cache. 4747 my($dirMap)=$self->getRevisionDirMap($revCommit); 4748 my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%); 4749 if(!defined($dir)) 4750 { 4751 $dir=""; 4752 } 4753 if( !defined($dirMap->{$dir}) || 4754 !defined($dirMap->{$dir}{$filename}) ) 4755 { 4756 my($fileHash)="deleted"; 4757 4758 my($retVal)={}; 4759 $retVal->{name}=$filename; 4760 $retVal->{filehash}=$fileHash; 4761 4762 # not needed and difficult to compute: 4763 $retVal->{revision}="0"; # $revision; 4764 $retVal->{commithash}=$revCommit; 4765 #$retVal->{author}=$commit->{author}; 4766 #$retVal->{modified}=convertToCvsDate($commit->{date}); 4767 #$retVal->{mode}=convertToDbMode($mode); 4768 4769 return $retVal; 4770 } 4771 4772 my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename"); 4773 chomp $fileHash; 4774 if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/)) 4775 { 4776 die "Invalid fileHash '$fileHash' looking up" 4777 ." '$revCommit:$filename'\n"; 4778 } 4779 4780 # information about most recent commit to modify $filename: 4781 open(my $gitLogPipe, '-|', 'git', 'rev-list', 4782 '--max-count=1', '--pretty', '--parents', 4783 $revCommit, '--', $filename) 4784 or die "Cannot call git-rev-list: $!"; 4785 my @commits=readCommits($gitLogPipe); 4786 close $gitLogPipe; 4787 if(scalar(@commits)!=1) 4788 { 4789 die "Can't find most recent commit changing $filename\n"; 4790 } 4791 my($commit)=$commits[0]; 4792 if( !defined($commit) || !defined($commit->{hash}) ) 4793 { 4794 return undef; 4795 } 4796 4797 # does this (commit,file) have a real assigned CVS revision number? 4798 my $tablename_rev = $self->tablename("revision"); 4799 my $db_query; 4800 $db_query = $self->{dbh}->prepare_cached( 4801 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?", 4802 {},1); 4803 $db_query->execute($filename, $commit->{hash}); 4804 my($meta)=$db_query->fetchrow_hashref; 4805 if($meta) 4806 { 4807 $meta->{revision} = "1.$meta->{revision}"; 4808 return $meta; 4809 } 4810 4811 # fall back on special revision number 4812 my($revision)=$commit->{hash}; 4813 $revision=~s/(..)/'.' . (hex($1)+100)/eg; 4814 $revision="2.1.1.2000$revision"; 4815 4816 # meta data about $filename: 4817 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', 4818 $commit->{hash}, '--', $filename) 4819 or die("Cannot call git-ls-tree : $!"); 4820 local $/ = "\0"; 4821 my $line; 4822 $line=<$filePipe>; 4823 if(defined(<$filePipe>)) 4824 { 4825 die "Expected only a single file for git-ls-tree $filename\n"; 4826 } 4827 close $filePipe; 4828 4829 chomp $line; 4830 unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o ) 4831 { 4832 die("Couldn't process git-ls-tree line : $line\n"); 4833 } 4834 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 ); 4835 4836 # save result: 4837 my($retVal)={}; 4838 $retVal->{name}=$filename; 4839 $retVal->{revision}=$revision; 4840 $retVal->{filehash}=$fileHash; 4841 $retVal->{commithash}=$revCommit; 4842 $retVal->{author}=$commit->{author}; 4843 $retVal->{modified}=convertToCvsDate($commit->{date}); 4844 $retVal->{mode}=convertToDbMode($mode); 4845 4846 return $retVal; 4847} 4848 4849=head2 lookupCommitRef 4850 4851Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches 4852the result so looking it up again is fast. 4853 4854=cut 4855 4856sub lookupCommitRef 4857{ 4858 my $self = shift; 4859 my $ref = shift; 4860 4861 my $commitHash = $self->{commitRefCache}{$ref}; 4862 if(defined($commitHash)) 4863 { 4864 return $commitHash; 4865 } 4866 4867 $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet", 4868 $self->unescapeRefName($ref)); 4869 $commitHash=~s/\s*$//; 4870 if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)) 4871 { 4872 $commitHash=undef; 4873 } 4874 4875 if( defined($commitHash) ) 4876 { 4877 my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash); 4878 if( ! ($type=~/^commit\s*$/ ) ) 4879 { 4880 $commitHash=undef; 4881 } 4882 } 4883 if(defined($commitHash)) 4884 { 4885 $self->{commitRefCache}{$ref}=$commitHash; 4886 } 4887 return $commitHash; 4888} 4889 4890=head2 clearCommitRefCaches 4891 4892Clears cached commit cache (sha1's for various tags/abbeviations/etc), 4893and related caches. 4894 4895=cut 4896 4897sub clearCommitRefCaches 4898{ 4899 my $self = shift; 4900 $self->{commitRefCache} = {}; 4901 $self->{revisionDirMapCache} = undef; 4902 $self->{gethead_cache} = undef; 4903} 4904 4905=head2 commitmessage 4906 4907this function takes a commithash and returns the commit message for that commit 4908 4909=cut 4910sub commitmessage 4911{ 4912 my $self = shift; 4913 my $commithash = shift; 4914 my $tablename = $self->tablename("commitmsgs"); 4915 4916 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ ); 4917 4918 my $db_query; 4919 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1); 4920 $db_query->execute($commithash); 4921 4922 my ( $message ) = $db_query->fetchrow_array; 4923 4924 if ( defined ( $message ) ) 4925 { 4926 $message .= " " if ( $message =~ /\n$/ ); 4927 return $message; 4928 } 4929 4930 my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash); 4931 shift @lines while ( $lines[0] =~ /\S/ ); 4932 $message = join("",@lines); 4933 $message .= " " if ( $message =~ /\n$/ ); 4934 return $message; 4935} 4936 4937=head2 gethistorydense 4938 4939This function takes a filename (with path) argument and returns an arrayofarrays 4940containing revision,filehash,commithash ordered by revision descending. 4941 4942This version of gethistory skips deleted entries -- so it is useful for annotate. 4943The 'dense' part is a reference to a '--dense' option available for git-rev-list 4944and other git tools that depend on it. 4945 4946See also getlog(). 4947 4948=cut 4949sub gethistorydense 4950{ 4951 my $self = shift; 4952 my $filename = shift; 4953 my $tablename = $self->tablename("revision"); 4954 4955 my $db_query; 4956 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1); 4957 $db_query->execute($filename); 4958 4959 my $result = $db_query->fetchall_arrayref; 4960 4961 my $i; 4962 for($i=0 ; $i<scalar(@$result) ; $i++) 4963 { 4964 $result->[$i][0]="1." . $result->[$i][0]; 4965 } 4966 4967 return $result; 4968} 4969 4970=head2 escapeRefName 4971 4972Apply an escape mechanism to compensate for characters that 4973git ref names can have that CVS tags can not. 4974 4975=cut 4976sub escapeRefName 4977{ 4978 my($self,$refName)=@_; 4979 4980 # CVS officially only allows [-_A-Za-z0-9] in tag names (or in 4981 # many contexts it can also be a CVS revision number). 4982 # 4983 # Git tags commonly use '/' and '.' as well, but also handle 4984 # anything else just in case: 4985 # 4986 # = "_-s-" For '/'. 4987 # = "_-p-" For '.'. 4988 # = "_-u-" For underscore, in case someone wants a literal "_-" in 4989 # a tag name. 4990 # = "_-xx-" Where "xx" is the hexadecimal representation of the 4991 # desired ASCII character byte. (for anything else) 4992 4993 if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/) 4994 { 4995 $refName=~s/_-/_-u--/g; 4996 $refName=~s/\./_-p-/g; 4997 $refName=~s%/%_-s-%g; 4998 $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg; 4999 } 5000} 5001 5002=head2 unescapeRefName 5003 5004Undo an escape mechanism to compensate for characters that 5005git ref names can have that CVS tags can not. 5006 5007=cut 5008sub unescapeRefName 5009{ 5010 my($self,$refName)=@_; 5011 5012 # see escapeRefName() for description of escape mechanism. 5013 5014 $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg; 5015 5016 # allowed tag names 5017 # TODO: Perhaps use git check-ref-format, with an in-process cache of 5018 # validated names? 5019 if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) || 5020 ( $refName=~m%[/.]$% ) || 5021 ( $refName=~/\.lock$/ ) || 5022 ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching } 5023 { 5024 # Error: 5025 $log->warn("illegal refName: $refName"); 5026 $refName=undef; 5027 } 5028 return $refName; 5029} 5030 5031sub unescapeRefNameChar 5032{ 5033 my($char)=@_; 5034 5035 if($char eq "s") 5036 { 5037 $char="/"; 5038 } 5039 elsif($char eq "p") 5040 { 5041 $char="."; 5042 } 5043 elsif($char eq "u") 5044 { 5045 $char="_"; 5046 } 5047 elsif($char=~/^[0-9a-f][0-9a-f]$/) 5048 { 5049 $char=chr(hex($char)); 5050 } 5051 else 5052 { 5053 # Error case: Maybe it has come straight from user, and 5054 # wasn't supposed to be escaped? Restore it the way we got it: 5055 $char="_-$char-"; 5056 } 5057 5058 return $char; 5059} 5060 5061=head2 in_array() 5062 5063from Array::PAT - mimics the in_array() function 5064found in PHP. Yuck but works for small arrays. 5065 5066=cut 5067sub in_array 5068{ 5069 my ($check, @array) = @_; 5070 my $retval = 0; 5071 foreach my $test (@array){ 5072 if($check eq $test){ 5073 $retval = 1; 5074 } 5075 } 5076 return $retval; 5077} 5078 5079=head2 mangle_dirname 5080 5081create a string from a directory name that is suitable to use as 5082part of a filename, mainly by converting all chars except \w.- to _ 5083 5084=cut 5085sub mangle_dirname { 5086 my $dirname = shift; 5087 return unless defined $dirname; 5088 5089 $dirname =~ s/[^\w.-]/_/g; 5090 5091 return $dirname; 5092} 5093 5094=head2 mangle_tablename 5095 5096create a string from a that is suitable to use as part of an SQL table 5097name, mainly by converting all chars except \w to _ 5098 5099=cut 5100sub mangle_tablename { 5101 my $tablename = shift; 5102 return unless defined $tablename; 5103 5104 $tablename =~ s/[^\w_]/_/g; 5105 5106 return $tablename; 5107} 5108 51091; 5110