reflog expire: narrow scope of "cb" in cmd_reflog_expire()
[git/debian.git] / git-cvsserver.perl
blob4c8118010a81f4da9cd2e52029cb9d6c7992975d
1 #!/usr/bin/perl
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 ####
18 use 5.008;
19 use strict;
20 use warnings;
21 use bytes;
23 use Fcntl;
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
26 use File::Basename;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
32 my $cfg;
34 my $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",
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50 $| = 1;
52 #### Definition and mappings of functions ####
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?
58 my $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,
90 ##############################################
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.
95 my $state = { prependdir => '' };
97 # Work is for managing temporary working directory
98 my $work =
100 state => undef, # undef, 1 (empty), 2 (with stuff)
101 workDir => undef,
102 index => undef,
103 emptyDir => undef,
104 tmpDir => undef
107 $log->info("--------------- STARTING -----------------");
109 my $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";
123 my @opts = ( 'h|H', 'version|V',
124 'base-path=s', 'strict-paths', 'export-all' );
125 GetOptions( $state, @opts )
126 or die $usage;
128 if ($state->{version}) {
129 print "git-cvsserver version $VERSION\n";
130 exit;
132 if ($state->{help}) {
133 print $usage;
134 exit;
137 my $TEMP_DIR = tempdir( CLEANUP => 1 );
138 $log->debug("Temporary directory is '$TEMP_DIR'");
140 $state->{method} = 'ext';
141 if (@ARGV) {
142 if ($ARGV[0] eq 'pserver') {
143 $state->{method} = 'pserver';
144 shift @ARGV;
145 } elsif ($ARGV[0] eq 'server') {
146 shift @ARGV;
150 # everything else is a directory
151 $state->{allowed_roots} = [ @ARGV ];
153 # don't export the whole system unless the users requests it
154 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
155 die "--export-all can only be used together with an explicit whitelist\n";
158 # Environment handling for running under git-shell
159 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
160 if ($state->{'base-path'}) {
161 die "Cannot specify base path both ways.\n";
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");
167 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
168 if (@{$state->{allowed_roots}}) {
169 die "Cannot specify roots both ways: @ARGV\n";
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");
176 # if we are called with a pserver argument,
177 # deal with the authentication cat before entering the
178 # main loop
179 if ($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";
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;
190 $line = <STDIN>; chomp $line;
191 my $user = $line;
192 $line = <STDIN>; chomp $line;
193 my $password = $line;
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;
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;
213 my $authdb = $cfg->{gitcvs}->{authdb};
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;
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;
231 close $passwd;
233 unless ($auth_ok) {
234 print "I HATE YOU\n";
235 exit 1;
238 # Fall through to LOVE
241 # For checking whether the user is anonymous on commit
242 $state->{user} = $user;
244 $line = <STDIN>; chomp $line;
245 unless ($line eq "END $request REQUEST") {
246 die "E Do not understand $line -- expecting END $request REQUEST\n";
248 print "I LOVE YOU\n";
249 exit if $request eq 'VERIFICATION'; # cvs login
250 # and now back to our regular programme...
253 # Keep going until the client closes the connection
254 while (<STDIN>)
256 chomp;
258 # Check to see if we've seen this method, and call appropriate function.
259 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
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 $_");
274 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
275 $log->info("--------------- FINISH -----------------");
277 chdir '/';
278 exit 0;
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.
284 sub req_CATCHALL
286 my ( $cmd, $data ) = @_;
287 $log->warn("Unhandled command : req_$cmd : $data");
290 # This method invariably succeeds with an empty response.
291 sub req_EMPTY
293 print "ok\n";
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.
305 sub req_Root
307 my ( $cmd, $data ) = @_;
308 $log->debug("req_Root : $data");
310 unless ($data =~ m#^/#) {
311 print "error 1 Root must be an absolute pathname\n";
312 return 0;
315 my $cvsroot = $state->{'base-path'} || '';
316 $cvsroot =~ s#/+$##;
317 $cvsroot .= $data;
319 if ($state->{CVSROOT}
320 && ($state->{CVSROOT} ne $cvsroot)) {
321 print "error 1 Conflicting roots specified\n";
322 return 0;
325 $state->{CVSROOT} = $cvsroot;
327 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
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;
339 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
340 $allowed = 1;
341 last;
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;
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;
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;
367 foreach my $line ( @gitvars )
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;
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;
388 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
389 if ( $logfile )
391 $log->setfile($logfile);
392 } else {
393 $log->nofile();
396 $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20;
397 $state->{hexsz} = $state->{rawsz} * 2;
399 return 1;
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.
409 sub req_Globaloption
411 my ( $cmd, $data ) = @_;
412 $log->debug("req_Globaloption : $data");
413 $state->{globaloptions}{$data} = 1;
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.
419 sub req_Validresponses
421 my ( $cmd, $data ) = @_;
422 $log->debug("req_Validresponses : $data");
424 # TODO : re-enable this, currently it's not particularly useful
425 #$state->{validresponses} = [ split /\s+/, $data ];
428 # valid-requests \n
429 # Response expected: yes. Ask the server to send back a Valid-requests
430 # response.
431 sub req_validrequests
433 my ( $cmd, $data ) = @_;
435 $log->debug("req_validrequests");
437 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
438 $log->debug("SEND : ok");
440 print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
441 print "ok\n";
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.
455 sub req_Directory
457 my ( $cmd, $data ) = @_;
459 my $repository = <STDIN>;
460 chomp $repository;
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/ );
470 $state->{directory} = $state->{localdir};
471 $state->{directory} = "" if ( $state->{directory} eq "." );
472 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
474 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
476 $log->info("Setting prepend to '$state->{path}'");
477 $state->{prependdir} = $state->{path};
478 my %entries;
479 foreach my $entry ( keys %{$state->{entries}} )
481 $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
483 $state->{entries}=\%entries;
485 my %dirMap;
486 foreach my $dir ( keys %{$state->{dirMap}} )
488 $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
490 $state->{dirMap}=\%dirMap;
493 if ( defined ( $state->{prependdir} ) )
495 $log->debug("Prepending '$state->{prependdir}' to state|directory");
496 $state->{directory} = $state->{prependdir} . $state->{directory}
499 if ( ! defined($state->{dirMap}{$state->{directory}}) )
501 $state->{dirMap}{$state->{directory}} =
503 'names' => {}
504 #'tagspec' => undef
508 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
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.
524 sub req_Sticky
526 my ( $cmd, $tagspec ) = @_;
528 my ( $stickyInfo );
529 if($tagspec eq "")
531 # nothing
533 elsif($tagspec=~/^T([^ ]+)\s*$/)
535 $stickyInfo = { 'tag' => $1 };
537 elsif($tagspec=~/^D([0-9.]+)\s*$/)
539 $stickyInfo= { 'date' => $1 };
541 else
543 die "Unknown tag_or_date format\n";
545 $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
547 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
548 . " path=$state->{path} directory=$state->{directory}"
549 . " module=$state->{module}");
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.
563 sub req_Entry
565 my ( $cmd, $data ) = @_;
567 #$log->debug("req_Entry : $data");
569 my @data = split(/\//, $data, -1);
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],
578 $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
580 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
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.
589 sub req_Questionable
591 my ( $cmd, $data ) = @_;
593 $log->debug("req_Questionable : $data");
594 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
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.
603 sub req_add
605 my ( $cmd, $data ) = @_;
607 argsplit("add");
609 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
610 $updater->update();
612 my $addcount = 0;
614 foreach my $filename ( @{$state->{args}} )
616 $filename = filecleanup($filename);
618 # no -r, -A, or -D with add
619 my $stickyInfo = resolveStickyInfo($filename);
621 my $meta = $updater->getmeta($filename,$stickyInfo);
622 my $wrev = revparse($filename);
624 if ($wrev && $meta && ($wrev=~/^-/))
626 # previously removed file, add back
627 $log->info("added file $filename was previously removed, send $meta->{revision}");
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";
635 unless ( $state->{globaloptions}{-n} )
637 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
639 print "Created $dirpart\n";
640 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
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});
655 next;
658 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
660 print "E cvs add: nothing known about `$filename'\n";
661 next;
663 # TODO : check we're not squashing an already existing file
664 if ( defined ( $state->{entries}{$filename}{revision} ) )
666 print "E cvs add: `$filename' has already been entered\n";
667 next;
670 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
672 print "E cvs add: scheduling file `$filename' for addition\n";
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";
681 my $requestedKopts = $state->{opt}{k};
682 if(defined($requestedKopts))
684 $requestedKopts = "-k$requestedKopts";
686 else
688 $requestedKopts = "";
690 if( $kopts ne $requestedKopts )
692 $log->warn("Ignoring requested -k='$requestedKopts'"
693 . " for '$filename'; detected -k='$kopts' instead");
694 #TODO: Also have option to send warning to user?
697 $addcount++;
700 if ( $addcount == 1 )
702 print "E cvs add: use `cvs commit' to add this file permanently\n";
704 elsif ( $addcount > 1 )
706 print "E cvs add: use `cvs commit' to add these files permanently\n";
709 print "ok\n";
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.
723 sub req_remove
725 my ( $cmd, $data ) = @_;
727 argsplit("remove");
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();
733 #$log->debug("add state : " . Dumper($state));
735 my $rmcount = 0;
737 foreach my $filename ( @{$state->{args}} )
739 $filename = filecleanup($filename);
741 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
743 print "E cvs remove: file `$filename' still in working directory\n";
744 next;
747 # only from entries
748 my $stickyInfo = resolveStickyInfo($filename);
750 my $meta = $updater->getmeta($filename,$stickyInfo);
751 my $wrev = revparse($filename);
753 unless ( defined ( $wrev ) )
755 print "E cvs remove: nothing known about `$filename'\n";
756 next;
759 if ( defined($wrev) and ($wrev=~/^-/) )
761 print "E cvs remove: file `$filename' already scheduled for removal\n";
762 next;
765 unless ( $wrev eq $meta->{revision} )
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;
773 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
775 print "E cvs remove: scheduling `$filename' for removal\n";
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";
782 $rmcount++;
785 if ( $rmcount == 1 )
787 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
789 elsif ( $rmcount > 1 )
791 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
794 print "ok\n";
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.
804 sub req_Modified
806 my ( $cmd, $data ) = @_;
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;
817 # Grab config information
818 my $blocksize = 8192;
819 my $bytesleft = $size;
820 my $tmp;
822 # Get a filehandle/name to write it to
823 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
825 # Loop over file data writing out to temporary file.
826 while ( $bytesleft )
828 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
829 read STDIN, $tmp, $blocksize;
830 print $fh $tmp;
831 $bytesleft -= $blocksize;
834 close $fh
835 or (print "E failed to write temporary, $filename: $!\n"), return;
837 # Ensure we have something sensible for the file mode
838 if ( $mode =~ /u=(\w+)/ )
840 $mode = $1;
841 } else {
842 $mode = "rw";
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;
851 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
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 `/'.
858 sub req_Unchanged
860 my ( $cmd, $data ) = @_;
862 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
864 #$log->debug("req_Unchanged : $data");
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.
874 sub req_Argument
876 my ( $cmd, $data ) = @_;
878 # Argumentx means: append to last Argument (with a newline in front)
880 $log->debug("$cmd : $data");
882 if ( $cmd eq 'Argumentx') {
883 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
884 } else {
885 push @{$state->{arguments}}, $data;
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:
911 sub req_expandmodules
913 my ( $cmd, $data ) = @_;
915 argsplit();
917 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
919 unless ( ref $state->{arguments} eq "ARRAY" )
921 print "ok\n";
922 return;
925 foreach my $module ( @{$state->{arguments}} )
927 $log->debug("SEND : Module-expansion $module");
928 print "Module-expansion $module\n";
931 print "ok\n";
932 statecleanup();
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.
942 sub req_co
944 my ( $cmd, $data ) = @_;
946 argsplit("co");
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";
956 print "ok\n";
957 return 1;
960 my $stickyInfo = { 'tag' => $state->{opt}{r},
961 'date' => $state->{opt}{D} };
963 my $module = $state->{args}[0];
964 $state->{module} = $module;
965 my $checkout_path = $module;
967 # use the user specified directory if we're given it
968 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
970 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
972 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
974 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
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();
980 my $headHash;
981 if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
983 $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
984 if( !defined($headHash) )
986 print "error 1 no such tag `$stickyInfo->{tag}'\n";
987 cleanupWorkTree();
988 exit;
992 $checkout_path =~ s|/$||; # get rid of trailing slashes
994 my %seendirs = ();
995 my $lastdir ='';
997 prepDirForOutput(
998 ".",
999 $state->{CVSROOT} . "/$module",
1000 $checkout_path,
1001 \%seendirs,
1002 'checkout',
1003 $state->{dirArgs} );
1005 foreach my $git ( @{$updater->getAnyHead($headHash)} )
1007 # Don't want to check out deleted files
1008 next if ( $git->{filehash} eq "deleted" );
1010 my $fullName = $git->{name};
1011 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
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;
1021 # modification time of this file
1022 print "Mod-time $git->{modified}\n";
1024 # print some information to the client
1025 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
1027 print "M U $checkout_path/$git->{dir}$git->{name}\n";
1028 } else {
1029 print "M U $checkout_path/$git->{name}\n";
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";
1035 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
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";
1044 # transmit file
1045 transmitfile($git->{filehash});
1048 print "ok\n";
1050 statecleanup();
1053 # used by req_co and req_update to set up directories for files
1054 # recursively handles parents
1055 sub prepDirForOutput
1057 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1059 my $parent = dirname($dir);
1060 $dir =~ s|/+$||;
1061 $repodir =~ s|/+$||;
1062 $remotedir =~ s|/+$||;
1063 $parent =~ s|/+$||;
1065 if ($parent eq '.' || $parent eq './')
1067 $parent = '';
1069 # recurse to announce unseen parents first
1070 if( length($parent) &&
1071 !exists($seendirs->{$parent}) &&
1072 ( $request eq "checkout" ||
1073 exists($dirArgs->{$parent}) ) )
1075 prepDirForOutput($parent, $repodir, $remotedir,
1076 $seendirs, $request, $dirArgs);
1078 # Announce that we are going to modify at the parent level
1079 if ($dir eq '.' || $dir eq './')
1081 $dir = '';
1083 if(exists($seendirs->{$dir}))
1085 return;
1087 $log->debug("announcedir $dir, $repodir, $remotedir" );
1088 my($thisRemoteDir,$thisRepoDir);
1089 if ($dir ne "")
1091 $thisRepoDir="$repodir/$dir";
1092 if($remotedir eq ".")
1094 $thisRemoteDir=$dir;
1096 else
1098 $thisRemoteDir="$remotedir/$dir";
1101 else
1103 $thisRepoDir=$repodir;
1104 $thisRemoteDir=$remotedir;
1106 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1108 print "E cvs $request: Updating $thisRemoteDir\n";
1111 my ($opt_r)=$state->{opt}{r};
1112 my $stickyInfo;
1113 if(exists($state->{opt}{A}))
1115 # $stickyInfo=undef;
1117 elsif( defined($opt_r) && $opt_r ne "" )
1118 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1120 $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
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) };
1128 else
1130 $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
1133 my $stickyResponse;
1134 if(defined($stickyInfo))
1136 $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1137 "$thisRepoDir/\n" .
1138 getStickyTagOrDate($stickyInfo) . "\n";
1140 else
1142 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1143 "$thisRepoDir/\n";
1146 unless ( $state->{globaloptions}{-n} )
1148 print $stickyResponse;
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";
1158 $seendirs->{$dir} = 1;
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.
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.
1173 sub req_update
1175 my ( $cmd, $data ) = @_;
1177 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1179 argsplit("update");
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.
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";
1195 print "ok\n";
1196 return 1;
1200 # Grab a handle to the SQLite db and do any necessary updates
1201 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1203 $updater->update();
1205 argsfromdir($updater);
1207 #$log->debug("update state : " . Dumper($state));
1209 my($repoDir);
1210 $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
1212 my %seendirs = ();
1214 # foreach file specified on the command line ...
1215 foreach my $argsFilename ( @{$state->{args}} )
1217 my $filename;
1218 $filename = filecleanup($argsFilename);
1220 $log->debug("Processing file $filename");
1222 # if we have a -C we should pretend we never saw modified stuff
1223 if ( exists ( $state->{opt}{C} ) )
1225 delete $state->{entries}{$filename}{modified_hash};
1226 delete $state->{entries}{$filename}{modified_filename};
1227 $state->{entries}{$filename}{unchanged} = 1;
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);
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});
1241 transmitfile($meta->{filehash}, { print => 1 });
1244 next;
1247 # Directories:
1248 prepDirForOutput(
1249 dirname($argsFilename),
1250 $repoDir,
1251 ".",
1252 \%seendirs,
1253 "update",
1254 $state->{dirArgs} );
1256 my $wrev = revparse($filename);
1258 if ( ! defined $meta )
1260 $meta = {
1261 name => $filename,
1262 revision => '0',
1263 filehash => 'added'
1265 if($wrev ne "0")
1267 $meta->{filehash}='deleted';
1271 my $oldmeta = $meta;
1273 # If the working copy is an old revision, lets get that version too for comparison.
1274 my $oldWrev=$wrev;
1275 if(defined($oldWrev))
1277 $oldWrev=~s/^-//;
1278 if($oldWrev ne $meta->{revision})
1280 $oldmeta = $updater->getmeta($filename, $oldWrev);
1284 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
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} ) );
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} ) )
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;
1310 if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
1312 # TODO: If it has been modified in the sandbox, error out
1313 # with the appropriate message, rather than deleting a modified
1314 # file.
1316 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1318 $log->info("Removing '$filename' from working copy (no longer in the repo)");
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";
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' )
1331 # normal update, just send the new revision (either U=Update,
1332 # or A=Add, or R=Remove)
1333 if ( defined($wrev) && ($wrev=~/^-/) )
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;
1341 elsif ( (!defined($wrev) || $wrev eq '0') &&
1342 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
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;
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";
1360 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1362 # Don't want to actually _DO_ the update if -n specified
1363 unless ( $state->{globaloptions}{-n} )
1365 if ( defined ( $wrev ) )
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
1373 $log->debug("Creating new file 'Created $dirpart'");
1374 print "Created $dirpart\n";
1376 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
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";
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";
1389 # transmit file
1390 transmitfile($meta->{filehash});
1392 } else {
1393 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1395 my $mergeDir = setupTmpDir();
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 });
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";
1409 $log->debug("Temporary directory for merge is $mergeDir");
1411 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1412 $return >>= 8;
1414 cleanupTmpDir();
1416 if ( $return == 0 )
1418 $log->info("Merged successfully");
1419 print "M M $filename\n";
1420 $log->debug("Merged $dirpart");
1422 # Don't want to actually _DO_ the update if -n specified
1423 unless ( $state->{globaloptions}{-n} )
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";
1436 elsif ( $return == 1 )
1438 $log->info("Merged with conflicts");
1439 print "E cvs update: conflicts found in $filename\n";
1440 print "M C $filename\n";
1442 # Don't want to actually _DO_ the update if -n specified
1443 unless ( $state->{globaloptions}{-n} )
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";
1454 else
1456 $log->warn("Merge failed");
1457 next;
1460 # Don't want to actually _DO_ the update if -n specified
1461 unless ( $state->{globaloptions}{-n} )
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";
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;
1479 # prepDirForOutput() any other existing directories unless they already
1480 # have the right sticky tag:
1481 unless ( $state->{globaloptions}{n} )
1483 my $dir;
1484 foreach $dir (keys(%{$state->{dirMap}}))
1486 if( ! $seendirs{$dir} &&
1487 exists($state->{dirArgs}{$dir}) )
1489 my($oldTag);
1490 $oldTag=$state->{dirMap}{$dir}{tagspec};
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...
1499 next;
1502 prepDirForOutput(
1503 $dir,
1504 $repoDir,
1505 ".",
1506 \%seendirs,
1507 'update',
1508 $state->{dirArgs} );
1511 # TODO?: Consider sending a final duplicate Sticky response
1512 # to more closely mimic real CVS.
1516 print "ok\n";
1519 sub req_ci
1521 my ( $cmd, $data ) = @_;
1523 argsplit("ci");
1525 #$log->debug("State : " . Dumper($state));
1527 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1529 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1531 print "error 1 anonymous user cannot commit via pserver\n";
1532 cleanupWorkTree();
1533 exit;
1536 if ( -e $state->{CVSROOT} . "/index" )
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;
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();
1548 my @committedfiles = ();
1549 my %oldmeta;
1550 my $stickyInfo;
1551 my $branchRef;
1552 my $parenthash;
1554 # foreach file specified on the command line ...
1555 foreach my $filename ( @{$state->{args}} )
1557 my $committedfile = $filename;
1558 $filename = filecleanup($filename);
1560 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1562 #####
1563 # Figure out which branch and parenthash we are committing
1564 # to, and setup worktree:
1566 # should always come from entries:
1567 my $fileStickyInfo = resolveStickyInfo($filename);
1568 if( !defined($branchRef) )
1570 $stickyInfo = $fileStickyInfo;
1571 if( defined($stickyInfo) &&
1572 ( defined($stickyInfo->{date}) ||
1573 !defined($stickyInfo->{tag}) ) )
1575 print "error 1 cannot commit with sticky date for file `$filename'\n";
1576 cleanupWorkTree();
1577 exit;
1580 $branchRef = "refs/heads/$state->{module}";
1581 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1583 $branchRef = "refs/heads/$stickyInfo->{tag}";
1586 $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
1587 chomp $parenthash;
1588 if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/)
1590 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1592 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1594 else
1596 print "error 1 pserver cannot find the current HEAD of module";
1598 cleanupWorkTree();
1599 exit;
1602 setupWorkTree($parenthash);
1604 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1606 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1608 elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
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;
1619 #####
1620 # Process this file:
1622 my $meta = $updater->getmeta($filename,$stickyInfo);
1623 $oldmeta{$filename} = $meta;
1625 my $wrev = revparse($filename);
1627 my ( $filepart, $dirpart ) = filenamesplit($filename);
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 : $!";
1637 my $addflag = 0;
1638 my $rmflag = 0;
1639 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1640 $addflag = 1 unless ( -e $filename );
1642 # Do up to date checking
1643 unless ( $addflag or $wrev eq $meta->{revision} or
1644 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
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;
1652 push @committedfiles, $committedfile;
1653 $log->info("Committing $filename");
1655 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1657 unless ( $rmflag )
1659 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1660 rename $state->{entries}{$filename}{modified_filename},$filename;
1662 # Calculate modes to remove
1663 my $invmode = "";
1664 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1666 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1667 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1670 if ( $rmflag )
1672 $log->info("Removing file '$filename'");
1673 unlink($filename);
1674 system("git", "update-index", "--remove", $filename);
1676 elsif ( $addflag )
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);
1686 unless ( scalar(@committedfiles) > 0 )
1688 print "E No files to commit\n";
1689 print "ok\n";
1690 cleanupWorkTree();
1691 return;
1694 my $treehash = safe_pipe_capture(qw(git write-tree));
1695 chomp $treehash;
1697 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
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"
1706 } else {
1707 print $msg_fh "\n\nvia git-CVS emulator\n";
1709 close $msg_fh;
1711 my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1712 chomp($commithash);
1713 $log->info("Commit hash : $commithash");
1715 unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ )
1717 $log->warn("Commit failed (Invalid commit hash)");
1718 print "error 1 Commit failed (unknown reason)\n";
1719 cleanupWorkTree();
1720 exit;
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 )
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;
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;
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 $!";
1750 local $SIG{PIPE} = sub { die 'pipe broke' };
1752 print $pipe "$parenthash $commithash $branchRef\n";
1754 close $pipe || die "bad pipe: $! $?";
1757 $updater->update();
1759 ### Then hooks/post-update
1760 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1761 if (-x $hook) {
1762 system($hook, $branchRef);
1765 # foreach file specified on the command line ...
1766 foreach my $filename ( @committedfiles )
1768 $filename = filecleanup($filename);
1770 my $meta = $updater->getmeta($filename,$stickyInfo);
1771 unless (defined $meta->{revision}) {
1772 $meta->{revision} = "1.1";
1775 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1777 $log->debug("Checked-in $dirpart : $filename");
1779 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1780 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
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";
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";
1799 cleanupWorkTree();
1800 print "ok\n";
1803 sub req_status
1805 my ( $cmd, $data ) = @_;
1807 argsplit("status");
1809 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1810 #$log->debug("status state : " . Dumper($state));
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();
1817 # if no files were specified, we need to work out what files we should
1818 # be providing status on ...
1819 argsfromdir($updater);
1821 # foreach file specified on the command line ...
1822 foreach my $filename ( @{$state->{args}} )
1824 $filename = filecleanup($filename);
1826 if ( exists($state->{opt}{l}) &&
1827 index($filename, '/', length($state->{prependdir})) >= 0 )
1829 next;
1832 my $wrev = revparse($filename);
1834 my $stickyInfo = resolveStickyInfo($filename);
1835 my $meta = $updater->getmeta($filename,$stickyInfo);
1836 my $oldmeta = $meta;
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} )
1842 my($rmRev)=$wrev;
1843 $rmRev=~s/^-//;
1844 $oldmeta = $updater->getmeta($filename, $rmRev);
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} ) ) )
1860 $status = "Up-to-date"
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} ) ) )
1873 $status ||= "Needs Checkout";
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} ) )
1880 $status ||= "Needs Checkout";
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} )
1890 $status ||= "Locally Modified";
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} )
1899 $status ||= "Needs Merge";
1902 if ( defined ( $state->{entries}{$filename}{revision} ) and
1903 ( !defined($meta->{revision}) ||
1904 $meta->{revision} eq "0" ) )
1906 $status ||= "Locally Added";
1908 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1909 $wrev eq "-$meta->{revision}" )
1911 $status ||= "Locally Removed";
1913 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1914 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1916 $status ||= "Unresolved Conflict";
1918 if ( 0 )
1920 $status ||= "File had conflicts on merge";
1923 $status ||= "Unknown";
1925 my ($filepart) = filenamesplit($filename);
1927 print "M =======" . ( "=" x 60 ) . "\n";
1928 print "M File: $filepart\tStatus: $status\n";
1929 if ( defined($state->{entries}{$filename}{revision}) )
1931 print "M Working revision:\t" .
1932 $state->{entries}{$filename}{revision} . "\n";
1933 } else {
1934 print "M Working revision:\tNo entry for $filename\n";
1936 if ( defined($meta->{revision}) )
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) )
1945 $tag="(none)";
1947 print "M Sticky Tag:\t\t$tag\n";
1948 my($date)=($tagOrDate=~m/^D(.+)$/);
1949 if( !defined($date) )
1951 $date="(none)";
1953 print "M Sticky Date:\t\t$date\n";
1954 my($options)=$state->{entries}{$filename}{options};
1955 if( $options eq "" )
1957 $options="(none)";
1959 print "M Sticky Options:\t\t$options\n";
1960 } else {
1961 print "M Repository revision:\tNo revision control file\n";
1963 print "M\n";
1966 print "ok\n";
1969 sub req_diff
1971 my ( $cmd, $data ) = @_;
1973 argsplit("diff");
1975 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1976 #$log->debug("status state : " . Dumper($state));
1978 my ($revision1, $revision2);
1979 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1981 $revision1 = $state->{opt}{r}[0];
1982 $revision2 = $state->{opt}{r}[1];
1983 } else {
1984 $revision1 = $state->{opt}{r};
1987 $log->debug("Diffing revisions " .
1988 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1989 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
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();
1996 # if no files were specified, we need to work out what files we should
1997 # be providing status on ...
1998 argsfromdir($updater);
2000 my($foundDiff);
2002 # foreach file specified on the command line ...
2003 foreach my $argFilename ( @{$state->{args}} )
2005 my($filename) = filecleanup($argFilename);
2007 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2009 my $wrev = revparse($filename);
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
2018 if ( defined ( $revision1 ) )
2020 $meta1 = $updater->getmeta($filename, $revision1);
2022 elsif( defined($wrev) && $wrev ne "0" )
2024 my($rmRev)=$wrev;
2025 $rmRev=~s/^-//;
2026 $meta1 = $updater->getmeta($filename, $rmRev);
2028 if ( !defined($meta1) ||
2029 $meta1->{filehash} eq "deleted" )
2031 if( !exists($state->{opt}{N}) )
2033 if(!defined($revision1))
2035 print "E File $filename at revision $revision1 doesn't exist\n";
2037 next;
2039 elsif( !defined($meta1) )
2041 $meta1 = {
2042 name => $filename,
2043 revision => '0',
2044 filehash => 'deleted'
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
2056 # if we have a second -r switch, use it too
2057 if ( defined ( $revision2 ) )
2059 $meta2 = $updater->getmeta($filename, $revision2);
2061 elsif(defined($state->{entries}{$filename}{modified_filename}))
2063 $file2 = $state->{entries}{$filename}{modified_filename};
2064 $meta2 = {
2065 name => $filename,
2066 revision => '0',
2067 filehash => 'modified'
2070 elsif( defined($wrev) && ($wrev!~/^-/) )
2072 if(!defined($revision1)) # no revision and no modifications:
2074 next;
2076 $meta2 = $updater->getmeta($filename, $wrev);
2078 if(!defined($file2))
2080 if ( !defined($meta2) ||
2081 $meta2->{filehash} eq "deleted" )
2083 if( !exists($state->{opt}{N}) )
2085 if(!defined($revision2))
2087 print "E File $filename at revision $revision2 doesn't exist\n";
2089 next;
2091 elsif( !defined($meta2) )
2093 $meta2 = {
2094 name => $filename,
2095 revision => '0',
2096 filehash => 'deleted'
2102 if( $meta1->{filehash} eq $meta2->{filehash} )
2104 $log->info("unchanged $filename");
2105 next;
2108 # Retrieve revision contents:
2109 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2110 transmitfile($meta1->{filehash}, { targetfile => $file1 });
2112 if(!defined($file2))
2114 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2115 transmitfile($meta2->{filehash}, { targetfile => $file2 });
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" )
2124 print "M retrieving revision $meta1->{revision}\n"
2126 if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
2128 print "M retrieving revision $meta2->{revision}\n"
2130 print "M diff ";
2131 foreach my $opt ( sort keys %{$state->{opt}} )
2133 if ( ref $state->{opt}{$opt} eq "ARRAY" )
2135 foreach my $value ( @{$state->{opt}{$opt}} )
2137 print "-$opt $value ";
2139 } else {
2140 print "-$opt ";
2141 if ( defined ( $state->{opt}{$opt} ) )
2143 print "$state->{opt}{$opt} "
2147 print "$argFilename\n";
2149 $log->info("Diffing $filename -r $meta1->{revision} -r " .
2150 ( $meta2->{revision} or "workingcopy" ));
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.)
2164 my (@diffCmd) = ( 'diff' );
2165 if ( exists($state->{opt}{N}) )
2167 push @diffCmd,"-N";
2169 if ( exists $state->{opt}{u} )
2171 push @diffCmd,("-u","-L");
2172 if( $meta1->{filehash} eq "deleted" )
2174 push @diffCmd,"/dev/null";
2175 } else {
2176 push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2179 if( defined($meta2->{filehash}) )
2181 if( $meta2->{filehash} eq "deleted" )
2183 push @diffCmd,("-L","/dev/null");
2184 } else {
2185 push @diffCmd,("-L",
2186 "$argFilename\trevision $meta2->{revision}");
2188 } else {
2189 push @diffCmd,("-L","$argFilename\tworking copy");
2192 push @diffCmd,($file1,$file2);
2193 if(!open(DIFF,"-|",@diffCmd))
2195 $log->warn("Unable to run diff: $!");
2197 my($diffLine);
2198 while(defined($diffLine=<DIFF>))
2200 print "M $diffLine";
2201 $foundDiff=1;
2203 close(DIFF);
2206 if($foundDiff)
2208 print "error \n";
2210 else
2212 print "ok\n";
2216 sub req_log
2218 my ( $cmd, $data ) = @_;
2220 argsplit("log");
2222 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
2223 #$log->debug("log state : " . Dumper($state));
2225 my ( $revFilter );
2226 if ( defined ( $state->{opt}{r} ) )
2228 $revFilter = $state->{opt}{r};
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();
2236 # if no files were specified, we need to work out what files we
2237 # should be providing status on ...
2238 argsfromdir($updater);
2240 # foreach file specified on the command line ...
2241 foreach my $filename ( @{$state->{args}} )
2243 $filename = filecleanup($filename);
2245 my $headmeta = $updater->getmeta($filename);
2247 my ($revisions,$totalrevisions) = $updater->getlog($filename,
2248 $revFilter);
2250 next unless ( scalar(@$revisions) );
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";
2265 foreach my $revision ( @$revisions )
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}) )
2273 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
2274 $3, $DATE_LIST->{$2}, $1, $4 );
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";
2286 print "M =======" . ( "=" x 70 ) . "\n";
2289 print "ok\n";
2292 sub req_annotate
2294 my ( $cmd, $data ) = @_;
2296 argsplit("annotate");
2298 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
2299 #$log->debug("status state : " . Dumper($state));
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();
2305 # if no files were specified, we need to work out what files we should be providing annotate on ...
2306 argsfromdir($updater);
2308 # we'll need a temporary checkout dir
2309 setupWorkTree();
2311 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
2313 # foreach file specified on the command line ...
2314 foreach my $filename ( @{$state->{args}} )
2316 $filename = filecleanup($filename);
2318 my $meta = $updater->getmeta($filename);
2320 next unless ( $meta->{revision} );
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];
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)
2335 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2336 return;
2338 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
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;
2347 $log->info("Annotate $filename");
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.
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;
2359 for (my $i=0; $i < @$revisions; $i++)
2361 print ANNOTATEHINTS $revisions->[$i][2];
2362 if ($i+1 < @$revisions) { # have we got a parent?
2363 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2365 print ANNOTATEHINTS "\n";
2368 print ANNOTATEHINTS "\n";
2369 close ANNOTATEHINTS
2370 or (print "E failed to write $a_hints: $!\n"), return;
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;
2377 my $metadata = {};
2378 print "E Annotations for $filename\n";
2379 print "E ***************\n";
2380 while ( <ANNOTATE> )
2382 if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i)
2384 my $commithash = $1;
2385 my $data = $2;
2386 unless ( defined ( $metadata->{$commithash} ) )
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)/ );
2392 printf("M %-7s (%-8s %10s): %s\n",
2393 $metadata->{$commithash}{revision},
2394 $metadata->{$commithash}{author},
2395 $metadata->{$commithash}{modified},
2396 $data
2398 } else {
2399 $log->warn("Error in annotate output! LINE: $_");
2400 print "E Annotate error \n";
2401 next;
2404 close ANNOTATE;
2407 # done; get out of the tempdir
2408 cleanupWorkTree();
2410 print "ok\n";
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.
2417 sub argsplit
2419 $state->{args} = [];
2420 $state->{files} = [];
2421 $state->{opt} = {};
2423 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2425 my $type = shift;
2427 if ( defined($type) )
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" );
2440 while ( scalar ( @{$state->{arguments}} ) > 0 )
2442 my $arg = shift @{$state->{arguments}};
2444 next if ( $arg eq "--" );
2445 next unless ( $arg =~ /\S/ );
2447 # if the argument looks like a switch
2448 if ( $arg =~ /^-(\w)(.*)/ )
2450 # if it's a switch that takes an argument
2451 if ( $opt->{$1} )
2453 # If this switch has already been provided
2454 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2456 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2457 if ( length($2) > 0 )
2459 push @{$state->{opt}{$1}},$2;
2460 } else {
2461 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2463 } else {
2464 # if there's extra data in the arg, use that as the argument for the switch
2465 if ( length($2) > 0 )
2467 $state->{opt}{$1} = $2;
2468 } else {
2469 $state->{opt}{$1} = shift @{$state->{arguments}};
2472 } else {
2473 $state->{opt}{$1} = undef;
2476 else
2478 push @{$state->{args}}, $arg;
2482 else
2484 my $mode = 0;
2486 foreach my $value ( @{$state->{arguments}} )
2488 if ( $value eq "--" )
2490 $mode++;
2491 next;
2493 push @{$state->{args}}, $value if ( $mode == 0 );
2494 push @{$state->{files}}, $value if ( $mode == 1 );
2499 # Used by argsfromdir
2500 sub expandArg
2502 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
2504 my $fullPath = filecleanup($path);
2506 # Is it a directory?
2507 if( defined($state->{dirMap}{$fullPath}) ||
2508 defined($state->{dirMap}{"$fullPath/"}) )
2510 # It is a directory in the user's sandbox.
2511 $isDir=1;
2513 if(defined($state->{entries}{$fullPath}))
2515 $log->fatal("Inconsistent file/dir type");
2516 die "Inconsistent file/dir type";
2519 elsif(defined($state->{entries}{$fullPath}))
2521 # It is a file in the user's sandbox.
2522 $isDir=0;
2524 my($revDirMap,$otherRevDirMap);
2525 if(!defined($isDir) || $isDir)
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)
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).
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.
2545 if(exists($state->{opt}{A}))
2547 $revDirMap=$updater->getRevisionDirMap();
2549 elsif( defined($state->{opt}{r}) and
2550 ref $state->{opt}{r} eq "ARRAY" )
2552 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
2553 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
2555 elsif(defined($state->{opt}{r}))
2557 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
2559 else
2561 my($sticky)=getDirStickyInfo($fullPath);
2562 $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
2565 # Is it a directory?
2566 if( defined($revDirMap->{$fullPath}) ||
2567 defined($otherRevDirMap->{$fullPath}) )
2569 $isDir=1;
2573 # What to do with it?
2574 if(!$isDir)
2576 $outNameMap->{$fullPath}=1;
2578 else
2580 $outDirMap->{$fullPath}=1;
2582 if(defined($revDirMap->{$fullPath}))
2584 addDirMapFiles($updater,$outNameMap,$outDirMap,
2585 $revDirMap->{$fullPath});
2587 if( defined($otherRevDirMap) &&
2588 defined($otherRevDirMap->{$fullPath}) )
2590 addDirMapFiles($updater,$outNameMap,$outDirMap,
2591 $otherRevDirMap->{$fullPath});
2596 # Used by argsfromdir
2597 # Add entries from dirMap to outNameMap. Also recurse into entries
2598 # that are subdirectories.
2599 sub addDirMapFiles
2601 my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
2603 my($fullName);
2604 foreach $fullName (keys(%$dirMap))
2606 my $cleanName=$fullName;
2607 if(defined($state->{prependdir}))
2609 if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2611 $log->fatal("internal error stripping prependdir");
2612 die "internal error stripping prependdir";
2616 if($dirMap->{$fullName} eq "F")
2618 $outNameMap->{$cleanName}=1;
2620 elsif($dirMap->{$fullName} eq "D")
2622 if(!$state->{opt}{l})
2624 expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
2627 else
2629 $log->fatal("internal error in addDirMapFiles");
2630 die "internal error in addDirMapFiles";
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.
2644 sub argsfromdir
2646 my $updater = shift;
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)
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".
2676 if(scalar(@{$state->{args}})==0)
2678 $state->{args} = [ "." ];
2680 my %allArgs;
2681 my %allDirs;
2682 for my $file (@{$state->{args}})
2684 expandArg($updater,\%allArgs,\%allDirs,$file);
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}})
2691 $allArgs{remove_prependdir($file)} = 1;
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);
2701 my $count=scalar(@piecesA);
2702 my $tmp=scalar(@piecesB);
2703 return $count<=>$tmp if($count!=$tmp);
2705 for($tmp=0;$tmp<$count;$tmp++)
2707 if($piecesA[$tmp] ne $piecesB[$tmp])
2709 return $piecesA[$tmp] cmp $piecesB[$tmp]
2712 return 0;
2713 } keys(%allArgs) ];
2716 ## look up directory sticky tag, of either fullPath or a parent:
2717 sub getDirStickyInfo
2719 my($fullPath)=@_;
2721 $fullPath=~s%/+$%%;
2722 while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
2724 $fullPath=~s%/?[^/]*$%%;
2727 if( !defined($state->{dirMap}{"$fullPath/"}) &&
2728 ( $fullPath eq "" ||
2729 $fullPath eq "." ) )
2731 return $state->{dirMap}{""}{stickyInfo};
2733 else
2735 return $state->{dirMap}{"$fullPath/"}{stickyInfo};
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.
2742 sub resolveStickyInfo
2744 my($filename,$stickyTag,$stickyDate,$reset) = @_;
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]
2754 my $result;
2755 if($reset)
2757 # $result=undef;
2759 elsif( defined($stickyTag) && $stickyTag ne "" )
2760 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
2762 $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
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) };
2770 elsif( defined($state->{entries}{$filename}) &&
2771 defined($state->{entries}{$filename}{tag_or_date}) &&
2772 $state->{entries}{$filename}{tag_or_date} ne "" )
2774 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
2775 if($tagOrDate=~/^T([^ ]+)\s*$/)
2777 $result = { 'tag' => $1 };
2779 elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2781 $result= { 'date' => $1 };
2783 else
2785 die "Unknown tag_or_date format\n";
2788 else
2790 $result=getDirStickyInfo($filename);
2793 return $result;
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).
2799 sub getStickyTagOrDate
2801 my($stickyInfo)=@_;
2803 my $result;
2804 if(defined($stickyInfo) && defined($stickyInfo->{tag}))
2806 $result="T$stickyInfo->{tag}";
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
2813 $result="";
2816 return $result;
2819 # This method cleans up the $state variable after a command that uses arguments has run
2820 sub statecleanup
2822 $state->{files} = [];
2823 $state->{dirArgs} = {};
2824 $state->{args} = [];
2825 $state->{arguments} = [];
2826 $state->{entries} = {};
2827 $state->{dirMap} = {};
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.
2834 sub revparse
2836 my $filename = shift;
2838 return $state->{entries}{$filename}{revision};
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.
2848 sub transmitfile
2850 my $filehash = shift;
2851 my $options = shift;
2853 if ( defined ( $filehash ) and $filehash eq "deleted" )
2855 $log->warn("filehash is 'deleted'");
2856 return;
2859 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
2861 my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
2862 chomp $type;
2864 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2866 my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
2867 chomp $size;
2869 $log->debug("transmitfile($filehash) size=$size, type=$type");
2871 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2873 if ( defined ( $options->{targetfile} ) )
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";
2887 } else {
2888 print "$size\n";
2889 print while ( <$fh> );
2891 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2892 } else {
2893 die("Couldn't execute git-cat-file");
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
2900 sub filenamesplit
2902 my $filename = shift;
2903 my $fixforlocaldir = shift;
2905 my ( $filepart, $dirpart ) = ( $filename, "." );
2906 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2907 $dirpart .= "/";
2909 if ( $fixforlocaldir )
2911 $dirpart =~ s/^$state->{prependdir}//;
2914 return ( $filepart, $dirpart );
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).
2920 sub filecleanup
2922 my $filename = shift;
2924 return undef unless(defined($filename));
2925 if ( $filename =~ /^\// )
2927 print "E absolute filenames '$filename' not supported by server\n";
2928 return undef;
2931 if($filename eq ".")
2933 $filename="";
2935 $filename =~ s/^\.\///g;
2936 $filename =~ s%/+%/%g;
2937 $filename = $state->{prependdir} . $filename;
2938 $filename =~ s%/$%%;
2939 return $filename;
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().
2945 sub remove_prependdir
2947 my($path) = @_;
2948 if(defined($state->{prependdir}) && $state->{prependdir} ne "")
2950 my($pre)=$state->{prependdir};
2951 $pre=~s%/$%%;
2952 if(!($path=~s%^\Q$pre\E/?%%))
2954 $log->fatal("internal error missing prependdir");
2955 die("internal error missing prependdir");
2958 return $path;
2961 sub validateGitDir
2963 if( !defined($state->{CVSROOT}) )
2965 print "error 1 CVSROOT not specified\n";
2966 cleanupWorkTree();
2967 exit;
2969 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2971 print "error 1 Internally inconsistent CVSROOT\n";
2972 cleanupWorkTree();
2973 exit;
2977 # Setup working directory in a work tree with the requested version
2978 # loaded in the index.
2979 sub setupWorkTree
2981 my ($ver) = @_;
2983 validateGitDir();
2985 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2986 defined($work->{tmpDir}) )
2988 $log->warn("Bad work tree state management");
2989 print "error 1 Internal setup multiple work trees without cleanup\n";
2990 cleanupWorkTree();
2991 exit;
2994 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2996 if( !defined($work->{index}) )
2998 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3001 chdir $work->{workDir} or
3002 die "Unable to chdir to $work->{workDir}\n";
3004 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3006 $ENV{GIT_WORK_TREE} = ".";
3007 $ENV{GIT_INDEX_FILE} = $work->{index};
3008 $work->{state} = 2;
3010 if($ver)
3012 system("git","read-tree",$ver);
3013 unless ($? == 0)
3015 $log->warn("Error running git-read-tree");
3016 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3019 # else # req_annotate reads tree for each file
3022 # Ensure current directory is in some kind of working directory,
3023 # with a recent version loaded in the index.
3024 sub ensureWorkTree
3026 if( defined($work->{tmpDir}) )
3028 $log->warn("Bad work tree state management [ensureWorkTree()]");
3029 print "error 1 Internal setup multiple dirs without cleanup\n";
3030 cleanupWorkTree();
3031 exit;
3033 if( $work->{state} )
3035 return;
3038 validateGitDir();
3040 if( !defined($work->{emptyDir}) )
3042 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
3044 chdir $work->{emptyDir} or
3045 die "Unable to chdir to $work->{emptyDir}\n";
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}}$/)
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;
3057 if( !defined($work->{index}) )
3059 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3062 $ENV{GIT_WORK_TREE} = ".";
3063 $ENV{GIT_INDEX_FILE} = $work->{index};
3064 $work->{state} = 1;
3066 system("git","read-tree",$ver);
3067 unless ($? == 0)
3069 die "Error running git-read-tree $ver $!\n";
3073 # Cleanup working directory that is not needed any longer.
3074 sub cleanupWorkTree
3076 if( ! $work->{state} )
3078 return;
3081 chdir "/" or die "Unable to chdir '/'\n";
3083 if( defined($work->{workDir}) )
3085 rmtree( $work->{workDir} );
3086 undef $work->{workDir};
3088 undef $work->{state};
3091 # Setup a temporary directory (not a working tree), typically for
3092 # merging dirty state as in req_update.
3093 sub setupTmpDir
3095 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
3096 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
3098 return $work->{tmpDir};
3101 # Clean up a previously setupTmpDir. Restore previous work tree if
3102 # appropriate.
3103 sub cleanupTmpDir
3105 if ( !defined($work->{tmpDir}) )
3107 $log->warn("cleanup tmpdir that has not been setup");
3108 die "Cleanup tmpDir that has not been setup\n";
3110 if( defined($work->{state}) )
3112 if( $work->{state} == 1 )
3114 chdir $work->{emptyDir} or
3115 die "Unable to chdir to $work->{emptyDir}\n";
3117 elsif( $work->{state} == 2 )
3119 chdir $work->{workDir} or
3120 die "Unable to chdir to $work->{emptyDir}\n";
3122 else
3124 $log->warn("Inconsistent work dir state");
3125 die "Inconsistent work dir state\n";
3128 else
3130 chdir "/" or die "Unable to chdir '/'\n";
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.
3137 sub kopts_from_path
3139 my ($path, $srcType, $name) = @_;
3141 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
3142 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
3144 my ($val) = check_attr( "text", $path );
3145 if ( $val eq "unspecified" )
3147 $val = check_attr( "crlf", $path );
3149 if ( $val eq "unset" )
3151 return "-kb"
3153 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
3154 $val eq "set" || $val eq "input" )
3156 return "";
3158 else
3160 $log->info("Unrecognized check_attr crlf $path : $val");
3164 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
3166 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
3168 return "-kb";
3170 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
3172 if( is_binary($srcType,$name) )
3174 $log->debug("... as binary");
3175 return "-kb";
3177 else
3179 $log->debug("... as text");
3183 # Return "" to give no special treatment to any path
3184 return "";
3187 sub check_attr
3189 my ($attr,$path) = @_;
3190 ensureWorkTree();
3191 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3193 my $val = <$fh>;
3194 close $fh;
3195 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3196 return $val;
3198 else
3200 return undef;
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.
3206 sub is_binary
3208 my ($srcType,$name) = @_;
3209 $log->debug("is_binary($srcType,$name)");
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++)
3218 $counts[$i]=0;
3221 my $fh = open_blob_or_die($srcType,$name);
3222 my $line;
3223 while( defined($line=<$fh>) )
3225 # Any '\0' and bare CR are considered binary.
3226 if( $line =~ /\0|(\r[^\n])/ )
3228 close($fh);
3229 return 1;
3232 # Count up each character in the line:
3233 my $len=length($line);
3234 for($i=0;$i<$len;$i++)
3236 $counts[ord(substr($line,$i,1))]++;
3239 close $fh;
3241 # Don't count CR and LF as either printable/nonprintable
3242 $counts[ord("\n")]=0;
3243 $counts[ord("\r")]=0;
3245 # Categorize individual character count into printable and nonprintable:
3246 my $printable=0;
3247 my $nonprintable=0;
3248 for($i=0;$i<256;$i++)
3250 if( $i < 32 &&
3251 $i != ord("\b") &&
3252 $i != ord("\t") &&
3253 $i != 033 && # ESC
3254 $i != 014 ) # FF
3256 $nonprintable+=$counts[$i];
3258 elsif( $i==127 ) # DEL
3260 $nonprintable+=$counts[$i];
3262 else
3264 $printable+=$counts[$i];
3268 return ($printable >> 7) < $nonprintable;
3271 # Returns open file handle. Possible invocations:
3272 # - open_blob_or_die("file",$filename);
3273 # - open_blob_or_die("sha1",$filehash);
3274 sub open_blob_or_die
3276 my ($srcType,$name) = @_;
3277 my ($fh);
3278 if( $srcType eq "file" )
3280 if( !open $fh,"<",$name )
3282 $log->warn("Unable to open file $name: $!");
3283 die "Unable to open file $name: $!\n";
3286 elsif( $srcType eq "sha1" )
3288 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ )
3290 $log->warn("Need filehash");
3291 die "Need filehash\n";
3294 my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
3295 chomp $type;
3297 unless ( defined ( $type ) and $type eq "blob" )
3299 $log->warn("Invalid type '$type' for '$name'");
3300 die ( "Invalid type '$type' (expected 'blob')" )
3303 my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
3304 chomp $size;
3306 $log->debug("open_blob_or_die($name) size=$size, type=$type");
3308 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3310 $log->warn("Unable to open sha1 $name");
3311 die "Unable to open sha1 $name\n";
3314 else
3316 $log->warn("Unknown type of blob source: $srcType");
3317 die "Unknown type of blob source: $srcType\n";
3319 return $fh;
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.
3327 sub cvs_author
3329 my $author_line = shift;
3330 (my $author) = $author_line =~ /<([^@>]*)/;
3332 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3333 $author =~ s/^-/_/;
3335 $author;
3339 sub descramble
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
3360 my ($str) = @_;
3362 # This should never happen, the same password format (A) has been
3363 # used by CVS since the beginning of time
3365 my $fmt = substr($str, 0, 1);
3366 die "invalid password format `$fmt'" unless $fmt eq 'A';
3369 my @str = unpack "C*", substr($str, 1);
3370 my $ret = join '', map { chr $SHIFTS[$_] } @str;
3371 return $ret;
3374 # Test if the (deep) values of two references to a hash are the same.
3375 sub refHashEqual
3377 my($v1,$v2) = @_;
3379 my $out;
3380 if(!defined($v1))
3382 if(!defined($v2))
3384 $out=1;
3387 elsif( !defined($v2) ||
3388 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3390 # $out=undef;
3392 else
3394 $out=1;
3396 my $key;
3397 foreach $key (keys(%{$v1}))
3399 if( !exists($v2->{$key}) ||
3400 defined($v1->{$key}) ne defined($v2->{$key}) ||
3401 ( defined($v1->{$key}) &&
3402 $v1->{$key} ne $v2->{$key} ) )
3404 $out=undef;
3405 last;
3410 return $out;
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
3416 sub safe_pipe_capture {
3418 my @output;
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
3426 return wantarray ? @output : join('',@output);
3430 package GITCVS::log;
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 ####
3440 use strict;
3441 use warnings;
3443 =head1 NAME
3445 GITCVS::log
3447 =head1 DESCRIPTION
3449 This module provides very crude logging with a similar interface to
3450 Log::Log4perl
3452 =head1 METHODS
3454 =cut
3456 =head2 new
3458 Creates a new log object, optionally you can specify a filename here to
3459 indicate the file to log to. If no log file is specified, you can specify one
3460 later with method setfile, or indicate you no longer want logging with method
3461 nofile.
3463 Until one of these methods is called, all log calls will buffer messages ready
3464 to write out.
3466 =cut
3467 sub new
3469 my $class = shift;
3470 my $filename = shift;
3472 my $self = {};
3474 bless $self, $class;
3476 if ( defined ( $filename ) )
3478 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3481 return $self;
3484 =head2 setfile
3486 This methods takes a filename, and attempts to open that file as the log file.
3487 If successful, all buffered data is written out to the file, and any further
3488 logging is written directly to the file.
3490 =cut
3491 sub setfile
3493 my $self = shift;
3494 my $filename = shift;
3496 if ( defined ( $filename ) )
3498 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3501 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3503 while ( my $line = shift @{$self->{buffer}} )
3505 print {$self->{fh}} $line;
3509 =head2 nofile
3511 This method indicates no logging is going to be used. It flushes any entries in
3512 the internal buffer, and sets a flag to ensure no further data is put there.
3514 =cut
3515 sub nofile
3517 my $self = shift;
3519 $self->{nolog} = 1;
3521 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3523 $self->{buffer} = [];
3526 =head2 _logopen
3528 Internal method. Returns true if the log file is open, false otherwise.
3530 =cut
3531 sub _logopen
3533 my $self = shift;
3535 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
3536 return 0;
3539 =head2 debug info warn fatal
3541 These four methods are wrappers to _log. They provide the actual interface for
3542 logging data.
3544 =cut
3545 sub debug { my $self = shift; $self->_log("debug", @_); }
3546 sub info { my $self = shift; $self->_log("info" , @_); }
3547 sub warn { my $self = shift; $self->_log("warn" , @_); }
3548 sub fatal { my $self = shift; $self->_log("fatal", @_); }
3550 =head2 _log
3552 This is an internal method called by the logging functions. It generates a
3553 timestamp and pushes the logged line either to file, or internal buffer.
3555 =cut
3556 sub _log
3558 my $self = shift;
3559 my $level = shift;
3561 return if ( $self->{nolog} );
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,
3574 if ( $self->_logopen )
3576 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
3577 } else {
3578 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
3582 =head2 DESTROY
3584 This method simply closes the file handle if one is open
3586 =cut
3587 sub DESTROY
3589 my $self = shift;
3591 if ( $self->_logopen )
3593 close $self->{fh};
3597 package GITCVS::updater;
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 ####
3607 use strict;
3608 use warnings;
3609 use DBI;
3610 our $_use_fsync;
3612 # n.b. consider using Git.pm
3613 sub use_fsync {
3614 if (!defined($_use_fsync)) {
3615 my $x = $ENV{GIT_TEST_FSYNC};
3616 if (defined $x) {
3617 local $ENV{GIT_CONFIG};
3618 delete $ENV{GIT_CONFIG};
3619 my $v = ::safe_pipe_capture('git', '-c', "test.fsync=$x",
3620 qw(config --type=bool test.fsync));
3621 $_use_fsync = defined($v) ? ($v eq "true\n") : 1;
3624 $_use_fsync;
3627 =head1 METHODS
3629 =cut
3631 =head2 new
3633 =cut
3634 sub new
3636 my $class = shift;
3637 my $config = shift;
3638 my $module = shift;
3639 my $log = shift;
3641 die "Need to specify a git repository" unless ( defined($config) and -d $config );
3642 die "Need to specify a module" unless ( defined($module) );
3644 $class = ref($class) || $class;
3646 my $self = {};
3648 bless $self, $class;
3650 $self->{valid_tables} = {'revision' => 1,
3651 'revision_ix1' => 1,
3652 'revision_ix2' => 1,
3653 'head' => 1,
3654 'head_ix1' => 1,
3655 'properties' => 1,
3656 'commitmsgs' => 1};
3658 $self->{module} = $module;
3659 $self->{git_path} = $config . "/";
3661 $self->{log} = $log;
3663 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
3665 # Stores full sha1's for various branch/tag names, abbreviations, etc:
3666 $self->{commitRefCache} = {};
3668 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
3669 $cfg->{gitcvs}{dbdriver} || "SQLite";
3670 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
3671 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
3672 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
3673 $cfg->{gitcvs}{dbuser} || "";
3674 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
3675 $cfg->{gitcvs}{dbpass} || "";
3676 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
3677 $cfg->{gitcvs}{dbtablenameprefix} || "";
3678 my %mapping = ( m => $module,
3679 a => $state->{method},
3680 u => getlogin || getpwuid($<) || $<,
3681 G => $self->{git_path},
3682 g => mangle_dirname($self->{git_path}),
3684 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
3685 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
3686 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
3687 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
3689 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
3690 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
3691 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
3692 $self->{dbuser},
3693 $self->{dbpass});
3694 die "Error connecting to database\n" unless defined $self->{dbh};
3695 if ($self->{dbdriver} eq 'SQLite' && !use_fsync()) {
3696 $self->{dbh}->do('PRAGMA synchronous = OFF');
3699 $self->{tables} = {};
3700 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3702 $self->{tables}{$table} = 1;
3705 # Construct the revision table if required
3706 # The revision table stores an entry for each file, each time that file
3707 # changes.
3708 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3709 # This is not sufficient to support "-r {commithash}" for any
3710 # files except files that were modified by that commit (also,
3711 # some places in the code ignore/effectively strip out -r in
3712 # some cases, before it gets passed to getmeta()).
3713 # The "filehash" field typically has a git blob hash, but can also
3714 # be set to "dead" to indicate that the given version of the file
3715 # should not exist in the sandbox.
3716 unless ( $self->{tables}{$self->tablename("revision")} )
3718 my $tablename = $self->tablename("revision");
3719 my $ix1name = $self->tablename("revision_ix1");
3720 my $ix2name = $self->tablename("revision_ix2");
3721 $self->{dbh}->do("
3722 CREATE TABLE $tablename (
3723 name TEXT NOT NULL,
3724 revision INTEGER NOT NULL,
3725 filehash TEXT NOT NULL,
3726 commithash TEXT NOT NULL,
3727 author TEXT NOT NULL,
3728 modified TEXT NOT NULL,
3729 mode TEXT NOT NULL
3732 $self->{dbh}->do("
3733 CREATE INDEX $ix1name
3734 ON $tablename (name,revision)
3736 $self->{dbh}->do("
3737 CREATE INDEX $ix2name
3738 ON $tablename (name,commithash)
3742 # Construct the head table if required
3743 # The head table (along with the "last_commit" entry in the property
3744 # table) is the persisted working state of the "sub update" subroutine.
3745 # All of it's data is read entirely first, and completely recreated
3746 # last, every time "sub update" runs.
3747 # This is also used by "sub getmeta" when it is asked for the latest
3748 # version of a file (as opposed to some specific version).
3749 # Another way of thinking about it is as a single slice out of
3750 # "revisions", giving just the most recent revision information for
3751 # each file.
3752 unless ( $self->{tables}{$self->tablename("head")} )
3754 my $tablename = $self->tablename("head");
3755 my $ix1name = $self->tablename("head_ix1");
3756 $self->{dbh}->do("
3757 CREATE TABLE $tablename (
3758 name TEXT NOT NULL,
3759 revision INTEGER NOT NULL,
3760 filehash TEXT NOT NULL,
3761 commithash TEXT NOT NULL,
3762 author TEXT NOT NULL,
3763 modified TEXT NOT NULL,
3764 mode TEXT NOT NULL
3767 $self->{dbh}->do("
3768 CREATE INDEX $ix1name
3769 ON $tablename (name)
3773 # Construct the properties table if required
3774 # - "last_commit" - Used by "sub update".
3775 unless ( $self->{tables}{$self->tablename("properties")} )
3777 my $tablename = $self->tablename("properties");
3778 $self->{dbh}->do("
3779 CREATE TABLE $tablename (
3780 key TEXT NOT NULL PRIMARY KEY,
3781 value TEXT
3786 # Construct the commitmsgs table if required
3787 # The commitmsgs table is only used for merge commits, since
3788 # "sub update" will only keep one branch of parents. Shortlogs
3789 # for ignored commits (i.e. not on the chosen branch) will be used
3790 # to construct a replacement "collapsed" merge commit message,
3791 # which will be stored in this table. See also "sub commitmessage".
3792 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3794 my $tablename = $self->tablename("commitmsgs");
3795 $self->{dbh}->do("
3796 CREATE TABLE $tablename (
3797 key TEXT NOT NULL PRIMARY KEY,
3798 value TEXT
3803 return $self;
3806 =head2 tablename
3808 =cut
3809 sub tablename
3811 my $self = shift;
3812 my $name = shift;
3814 if (exists $self->{valid_tables}{$name}) {
3815 return $self->{dbtablenameprefix} . $name;
3816 } else {
3817 return undef;
3821 =head2 update
3823 Bring the database up to date with the latest changes from
3824 the git repository.
3826 Internal working state is read out of the "head" table and the
3827 "last_commit" property, then it updates "revisions" based on that, and
3828 finally it writes the new internal state back to the "head" table
3829 so it can be used as a starting point the next time update is called.
3831 =cut
3832 sub update
3834 my $self = shift;
3836 # first lets get the commit list
3837 $ENV{GIT_DIR} = $self->{git_path};
3839 my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
3840 chomp $commitsha1;
3842 my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
3843 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ )
3845 die("Invalid module '$self->{module}'");
3849 my $git_log;
3850 my $lastcommit = $self->_get_prop("last_commit");
3852 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3853 # invalidate the gethead cache
3854 $self->clearCommitRefCaches();
3855 return 1;
3858 # Start exclusive lock here...
3859 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3861 # TODO: log processing is memory bound
3862 # if we can parse into a 2nd file that is in reverse order
3863 # we can probably do something really efficient
3864 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3866 if (defined $lastcommit) {
3867 push @git_log_params, "$lastcommit..$self->{module}";
3868 } else {
3869 push @git_log_params, $self->{module};
3871 # git-rev-list is the backend / plumbing version of git-log
3872 open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
3873 or die "Cannot call git-rev-list: $!";
3874 my @commits=readCommits($gitLogPipe);
3875 close $gitLogPipe;
3877 # Now all the commits are in the @commits bucket
3878 # ordered by time DESC. for each commit that needs processing,
3879 # determine whether it's following the last head we've seen or if
3880 # it's on its own branch, grab a file list, and add whatever's changed
3881 # NOTE: $lastcommit refers to the last commit from previous run
3882 # $lastpicked is the last commit we picked in this run
3883 my $lastpicked;
3884 my $head = {};
3885 if (defined $lastcommit) {
3886 $lastpicked = $lastcommit;
3889 my $committotal = scalar(@commits);
3890 my $commitcount = 0;
3892 # Load the head table into $head (for cached lookups during the update process)
3893 foreach my $file ( @{$self->gethead(1)} )
3895 $head->{$file->{name}} = $file;
3898 foreach my $commit ( @commits )
3900 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3901 if (defined $lastpicked)
3903 if (!in_array($lastpicked, @{$commit->{parents}}))
3905 # skip, we'll see this delta
3906 # as part of a merge later
3907 # warn "skipping off-track $commit->{hash}\n";
3908 next;
3909 } elsif (@{$commit->{parents}} > 1) {
3910 # it is a merge commit, for each parent that is
3911 # not $lastpicked (not given a CVS revision number),
3912 # see if we can get a log
3913 # from the merge-base to that parent to put it
3914 # in the message as a merge summary.
3915 my @parents = @{$commit->{parents}};
3916 foreach my $parent (@parents) {
3917 if ($parent eq $lastpicked) {
3918 next;
3920 # git-merge-base can potentially (but rarely) throw
3921 # several candidate merge bases. let's assume
3922 # that the first one is the best one.
3923 my $base = eval {
3924 ::safe_pipe_capture('git', 'merge-base',
3925 $lastpicked, $parent);
3927 # The two branches may not be related at all,
3928 # in which case merge base simply fails to find
3929 # any, but that's Ok.
3930 next if ($@);
3932 chomp $base;
3933 if ($base) {
3934 my @merged;
3935 # print "want to log between $base $parent \n";
3936 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3937 or die "Cannot call git-log: $!";
3938 my $mergedhash;
3939 while (<GITLOG>) {
3940 chomp;
3941 if (!defined $mergedhash) {
3942 if (m/^commit\s+(.+)$/) {
3943 $mergedhash = $1;
3944 } else {
3945 next;
3947 } else {
3948 # grab the first line that looks non-rfc822
3949 # aka has content after leading space
3950 if (m/^\s+(\S.*)$/) {
3951 my $title = $1;
3952 $title = substr($title,0,100); # truncate
3953 unshift @merged, "$mergedhash $title";
3954 undef $mergedhash;
3958 close GITLOG;
3959 if (@merged) {
3960 $commit->{mergemsg} = $commit->{message};
3961 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3962 foreach my $summary (@merged) {
3963 $commit->{mergemsg} .= "\t$summary\n";
3965 $commit->{mergemsg} .= "\n\n";
3966 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3973 # convert the date to CVS-happy format
3974 my $cvsDate = convertToCvsDate($commit->{date});
3976 if ( defined ( $lastpicked ) )
3978 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3979 local ($/) = "\0";
3980 while ( <FILELIST> )
3982 chomp;
3983 unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o )
3985 die("Couldn't process git-diff-tree line : $_");
3987 my ($mode, $hash, $change) = ($1, $2, $3);
3988 my $name = <FILELIST>;
3989 chomp($name);
3991 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3993 my $dbMode = convertToDbMode($mode);
3995 if ( $change eq "D" )
3997 #$log->debug("DELETE $name");
3998 $head->{$name} = {
3999 name => $name,
4000 revision => $head->{$name}{revision} + 1,
4001 filehash => "deleted",
4002 commithash => $commit->{hash},
4003 modified => $cvsDate,
4004 author => $commit->{author},
4005 mode => $dbMode,
4007 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4009 elsif ( $change eq "M" || $change eq "T" )
4011 #$log->debug("MODIFIED $name");
4012 $head->{$name} = {
4013 name => $name,
4014 revision => $head->{$name}{revision} + 1,
4015 filehash => $hash,
4016 commithash => $commit->{hash},
4017 modified => $cvsDate,
4018 author => $commit->{author},
4019 mode => $dbMode,
4021 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4023 elsif ( $change eq "A" )
4025 #$log->debug("ADDED $name");
4026 $head->{$name} = {
4027 name => $name,
4028 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
4029 filehash => $hash,
4030 commithash => $commit->{hash},
4031 modified => $cvsDate,
4032 author => $commit->{author},
4033 mode => $dbMode,
4035 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4037 else
4039 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
4040 die;
4043 close FILELIST;
4044 } else {
4045 # this is used to detect files removed from the repo
4046 my $seen_files = {};
4048 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
4049 local $/ = "\0";
4050 while ( <FILELIST> )
4052 chomp;
4053 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4055 die("Couldn't process git-ls-tree line : $_");
4058 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4060 $seen_files->{$git_filename} = 1;
4062 my ( $oldhash, $oldrevision, $oldmode ) = (
4063 $head->{$git_filename}{filehash},
4064 $head->{$git_filename}{revision},
4065 $head->{$git_filename}{mode}
4068 my $dbMode = convertToDbMode($mode);
4070 # unless the file exists with the same hash, we need to update it ...
4071 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
4073 my $newrevision = ( $oldrevision or 0 ) + 1;
4075 $head->{$git_filename} = {
4076 name => $git_filename,
4077 revision => $newrevision,
4078 filehash => $git_hash,
4079 commithash => $commit->{hash},
4080 modified => $cvsDate,
4081 author => $commit->{author},
4082 mode => $dbMode,
4086 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4089 close FILELIST;
4091 # Detect deleted files
4092 foreach my $file ( sort keys %$head )
4094 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
4096 $head->{$file}{revision}++;
4097 $head->{$file}{filehash} = "deleted";
4098 $head->{$file}{commithash} = $commit->{hash};
4099 $head->{$file}{modified} = $cvsDate;
4100 $head->{$file}{author} = $commit->{author};
4102 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
4105 # END : "Detect deleted files"
4109 if (exists $commit->{mergemsg})
4111 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
4114 $lastpicked = $commit->{hash};
4116 $self->_set_prop("last_commit", $commit->{hash});
4119 $self->delete_head();
4120 foreach my $file ( sort keys %$head )
4122 $self->insert_head(
4123 $file,
4124 $head->{$file}{revision},
4125 $head->{$file}{filehash},
4126 $head->{$file}{commithash},
4127 $head->{$file}{modified},
4128 $head->{$file}{author},
4129 $head->{$file}{mode},
4132 # invalidate the gethead cache
4133 $self->clearCommitRefCaches();
4136 # Ending exclusive lock here
4137 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
4140 sub readCommits
4142 my $pipeHandle = shift;
4143 my @commits;
4145 my %commit = ();
4147 while ( <$pipeHandle> )
4149 chomp;
4150 if (m/^commit\s+(.*)$/) {
4151 # on ^commit lines put the just seen commit in the stack
4152 # and prime things for the next one
4153 if (keys %commit) {
4154 my %copy = %commit;
4155 unshift @commits, \%copy;
4156 %commit = ();
4158 my @parents = split(m/\s+/, $1);
4159 $commit{hash} = shift @parents;
4160 $commit{parents} = \@parents;
4161 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
4162 # on rfc822-like lines seen before we see any message,
4163 # lowercase the entry and put it in the hash as key-value
4164 $commit{lc($1)} = $2;
4165 } else {
4166 # message lines - skip initial empty line
4167 # and trim whitespace
4168 if (!exists($commit{message}) && m/^\s*$/) {
4169 # define it to mark the end of headers
4170 $commit{message} = '';
4171 next;
4173 s/^\s+//; s/\s+$//; # trim ws
4174 $commit{message} .= $_ . "\n";
4178 unshift @commits, \%commit if ( keys %commit );
4180 return @commits;
4183 sub convertToCvsDate
4185 my $date = shift;
4186 # Convert from: "git rev-list --pretty" formatted date
4187 # Convert to: "the format specified by RFC822 as modified by RFC1123."
4188 # Example: 26 May 1997 13:01:40 -0400
4189 if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
4191 $date = "$2 $1 $4 $3 $5";
4194 return $date;
4197 sub convertToDbMode
4199 my $mode = shift;
4201 # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
4202 # but the database "mode" column historically (and currently)
4203 # only stores the "rw" (for user) part of the string.
4204 # FUTURE: It might make more sense to persist the raw
4205 # octal mode (or perhaps the final full CVS form) instead of
4206 # this half-converted form, but it isn't currently worth the
4207 # backwards compatibility headaches.
4209 $mode=~/^\d{3}(\d)\d\d$/;
4210 my $userBits=$1;
4212 my $dbMode = "";
4213 $dbMode .= "r" if ( $userBits & 4 );
4214 $dbMode .= "w" if ( $userBits & 2 );
4215 $dbMode .= "x" if ( $userBits & 1 );
4216 $dbMode = "rw" if ( $dbMode eq "" );
4218 return $dbMode;
4221 sub insert_rev
4223 my $self = shift;
4224 my $name = shift;
4225 my $revision = shift;
4226 my $filehash = shift;
4227 my $commithash = shift;
4228 my $modified = shift;
4229 my $author = shift;
4230 my $mode = shift;
4231 my $tablename = $self->tablename("revision");
4233 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4234 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4237 sub insert_mergelog
4239 my $self = shift;
4240 my $key = shift;
4241 my $value = shift;
4242 my $tablename = $self->tablename("commitmsgs");
4244 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4245 $insert_mergelog->execute($key, $value);
4248 sub delete_head
4250 my $self = shift;
4251 my $tablename = $self->tablename("head");
4253 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
4254 $delete_head->execute();
4257 sub insert_head
4259 my $self = shift;
4260 my $name = shift;
4261 my $revision = shift;
4262 my $filehash = shift;
4263 my $commithash = shift;
4264 my $modified = shift;
4265 my $author = shift;
4266 my $mode = shift;
4267 my $tablename = $self->tablename("head");
4269 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4270 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4273 sub _get_prop
4275 my $self = shift;
4276 my $key = shift;
4277 my $tablename = $self->tablename("properties");
4279 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4280 $db_query->execute($key);
4281 my ( $value ) = $db_query->fetchrow_array;
4283 return $value;
4286 sub _set_prop
4288 my $self = shift;
4289 my $key = shift;
4290 my $value = shift;
4291 my $tablename = $self->tablename("properties");
4293 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
4294 $db_query->execute($value, $key);
4296 unless ( $db_query->rows )
4298 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4299 $db_query->execute($key, $value);
4302 return $value;
4305 =head2 gethead
4307 =cut
4309 sub gethead
4311 my $self = shift;
4312 my $intRev = shift;
4313 my $tablename = $self->tablename("head");
4315 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
4317 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
4318 $db_query->execute();
4320 my $tree = [];
4321 while ( my $file = $db_query->fetchrow_hashref )
4323 if(!$intRev)
4325 $file->{revision} = "1.$file->{revision}"
4327 push @$tree, $file;
4330 $self->{gethead_cache} = $tree;
4332 return $tree;
4335 =head2 getAnyHead
4337 Returns a reference to an array of getmeta structures, one
4338 per file in the specified tree hash.
4340 =cut
4342 sub getAnyHead
4344 my ($self,$hash) = @_;
4346 if(!defined($hash))
4348 return $self->gethead();
4351 my @files;
4353 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4354 or die("Cannot call git-ls-tree : $!");
4355 local $/ = "\0";
4356 @files=<$filePipe>;
4357 close $filePipe;
4360 my $tree=[];
4361 my($line);
4362 foreach $line (@files)
4364 $line=~s/\0$//;
4365 unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4367 die("Couldn't process git-ls-tree line : $_");
4370 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4371 push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
4374 return $tree;
4377 =head2 getRevisionDirMap
4379 A "revision dir map" contains all the plain-file filenames associated
4380 with a particular revision (tree-ish), organized by directory:
4382 $type = $out->{$dir}{$fullName}
4384 The type of each is "F" (for ordinary file) or "D" (for directory,
4385 for which the map $out->{$fullName} will also exist).
4387 =cut
4389 sub getRevisionDirMap
4391 my ($self,$ver)=@_;
4393 if(!defined($self->{revisionDirMapCache}))
4395 $self->{revisionDirMapCache}={};
4398 # Get file list (previously cached results are dependent on HEAD,
4399 # but are early in each case):
4400 my $cacheKey;
4401 my (@fileList);
4402 if( !defined($ver) || $ver eq "" )
4404 $cacheKey="";
4405 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4407 return $self->{revisionDirMapCache}{$cacheKey};
4410 my @head = @{$self->gethead()};
4411 foreach my $file ( @head )
4413 next if ( $file->{filehash} eq "deleted" );
4415 push @fileList,$file->{name};
4418 else
4420 my ($hash)=$self->lookupCommitRef($ver);
4421 if( !defined($hash) )
4423 return undef;
4426 $cacheKey=$hash;
4427 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4429 return $self->{revisionDirMapCache}{$cacheKey};
4432 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4433 or die("Cannot call git-ls-tree : $!");
4434 local $/ = "\0";
4435 while ( <$filePipe> )
4437 chomp;
4438 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4440 die("Couldn't process git-ls-tree line : $_");
4443 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4445 push @fileList, $git_filename;
4447 close $filePipe;
4450 # Convert to normalized form:
4451 my %revMap;
4452 my $file;
4453 foreach $file (@fileList)
4455 my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
4456 $dir='' if(!defined($dir));
4458 # parent directories:
4459 # ... create empty dir maps for parent dirs:
4460 my($td)=$dir;
4461 while(!defined($revMap{$td}))
4463 $revMap{$td}={};
4465 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4466 $tp='' if(!defined($tp));
4467 $td=$tp;
4469 # ... add children to parent maps (now that they exist):
4470 $td=$dir;
4471 while($td ne "")
4473 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4474 $tp='' if(!defined($tp));
4476 if(defined($revMap{$tp}{$td}))
4478 if($revMap{$tp}{$td} ne 'D')
4480 die "Weird file/directory inconsistency in $cacheKey";
4482 last; # loop exit
4484 $revMap{$tp}{$td}='D';
4486 $td=$tp;
4489 # file
4490 $revMap{$dir}{$file}='F';
4493 # Save in cache:
4494 $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
4495 return $self->{revisionDirMapCache}{$cacheKey};
4498 =head2 getlog
4500 See also gethistorydense().
4502 =cut
4504 sub getlog
4506 my $self = shift;
4507 my $filename = shift;
4508 my $revFilter = shift;
4510 my $tablename = $self->tablename("revision");
4512 # Filters:
4513 # TODO: date, state, or by specific logins filters?
4514 # TODO: Handle comma-separated list of revFilter items, each item
4515 # can be a range [only case currently handled] or individual
4516 # rev or branch or "branch.".
4517 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
4518 # manually filtering the results of the query?
4519 my ( $minrev, $maxrev );
4520 if( defined($revFilter) and
4521 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
4523 my $control = $3;
4524 $minrev = $2;
4525 $maxrev = $5;
4526 $minrev++ if ( defined($minrev) and $control eq "::" );
4529 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
4530 $db_query->execute($filename);
4532 my $totalRevs=0;
4533 my $tree = [];
4534 while ( my $file = $db_query->fetchrow_hashref )
4536 $totalRevs++;
4537 if( defined($minrev) and $file->{revision} < $minrev )
4539 next;
4541 if( defined($maxrev) and $file->{revision} > $maxrev )
4543 next;
4546 $file->{revision} = "1." . $file->{revision};
4547 push @$tree, $file;
4550 return ($tree,$totalRevs);
4553 =head2 getmeta
4555 This function takes a filename (with path) argument and returns a hashref of
4556 metadata for that file.
4558 There are several ways $revision can be specified:
4560 - A reference to hash that contains a "tag" that is the
4561 actual revision (one of the below). TODO: Also allow it to
4562 specify a "date" in the hash.
4563 - undef, to refer to the latest version on the main branch.
4564 - Full CVS client revision number (mapped to integer in DB, without the
4565 "1." prefix),
4566 - Complex CVS-compatible "special" revision number for
4567 non-linear history (see comment below)
4568 - git commit sha1 hash
4569 - branch or tag name
4571 =cut
4573 sub getmeta
4575 my $self = shift;
4576 my $filename = shift;
4577 my $revision = shift;
4578 my $tablename_rev = $self->tablename("revision");
4579 my $tablename_head = $self->tablename("head");
4581 if ( ref($revision) eq "HASH" )
4583 $revision = $revision->{tag};
4586 # Overview of CVS revision numbers:
4588 # General CVS numbering scheme:
4589 # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
4590 # - Result of "cvs checkin -r" (possible, but not really
4591 # recommended): "2.1", "2.2", etc
4592 # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
4593 # from, "0" is a magic placeholder that identifies it as a
4594 # branch tag instead of a version tag, and n is 2 times the
4595 # branch number off of "1.2", starting with "2".
4596 # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
4597 # is branch number off of "1.2" (like n above), and "x" is
4598 # the version number on the branch.
4599 # - Branches can branch off of branches: "1.3.2.7.4.1" (even number
4600 # of components).
4601 # - Odd "n"s are used by "vendor branches" that result
4602 # from "cvs import". Vendor branches have additional
4603 # strangeness in the sense that the main rcs "head" of the main
4604 # branch will (temporarily until first normal commit) point
4605 # to the version on the vendor branch, rather than the actual
4606 # main branch. (FUTURE: This may provide an opportunity
4607 # to use "strange" revision numbers for fast-forward-merged
4608 # branch tip when CVS client is asking for the main branch.)
4610 # git-cvsserver CVS-compatible special numbering schemes:
4611 # - Currently git-cvsserver only tries to be identical to CVS for
4612 # simple "1.x" numbers on the "main" branch (as identified
4613 # by the module name that was originally cvs checkout'ed).
4614 # - The database only stores the "x" part, for historical reasons.
4615 # But most of the rest of the cvsserver preserves
4616 # and thinks using the full revision number.
4617 # - To handle non-linear history, it uses a version of the form
4618 # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
4619 # identify this as a special revision number, and there are
4620 # 20 b's that together encode the sha1 git commit from which
4621 # this version of this file originated. Each b is
4622 # the numerical value of the corresponding byte plus
4623 # 100.
4624 # - "plus 100" avoids "0"s, and also reduces the
4625 # likelihood of a collision in the case that someone someday
4626 # writes an import tool that tries to preserve original
4627 # CVS revision numbers, and the original CVS data had done
4628 # lots of branches off of branches and other strangeness to
4629 # end up with a real version number that just happens to look
4630 # like this special revision number form. Also, if needed
4631 # there are several ways to extend/identify alternative encodings
4632 # within the "2.1.1.2000" part if necessary.
4633 # - Unlike real CVS revisions, you can't really reconstruct what
4634 # relation a revision of this form has to other revisions.
4635 # - FUTURE: TODO: Rework database somehow to make up and remember
4636 # fully-CVS-compatible branches and branch version numbers.
4638 my $meta;
4639 if ( defined($revision) )
4641 if ( $revision =~ /^1\.(\d+)$/ )
4643 my ($intRev) = $1;
4644 my $db_query;
4645 $db_query = $self->{dbh}->prepare_cached(
4646 "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
4647 {},1);
4648 $db_query->execute($filename, $intRev);
4649 $meta = $db_query->fetchrow_hashref;
4651 elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ )
4653 my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
4654 $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
4655 if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)
4657 return $self->getMetaFromCommithash($filename,$commitHash);
4660 # error recovery: fall back on head version below
4661 print "E Failed to find $filename version=$revision or commit=$commitHash\n";
4662 $log->warning("failed get $revision with commithash=$commitHash");
4663 undef $revision;
4665 elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ )
4667 # Try DB first. This is mostly only useful for req_annotate(),
4668 # which only calls this for stuff that should already be in
4669 # the DB. It is fairly likely to be a waste of time
4670 # in most other cases [unless the file happened to be
4671 # modified in $revision specifically], but
4672 # it is probably in the noise compared to how long
4673 # getMetaFromCommithash() will take.
4674 my $db_query;
4675 $db_query = $self->{dbh}->prepare_cached(
4676 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4677 {},1);
4678 $db_query->execute($filename, $revision);
4679 $meta = $db_query->fetchrow_hashref;
4681 if(! $meta)
4683 my($revCommit)=$self->lookupCommitRef($revision);
4684 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4686 return $self->getMetaFromCommithash($filename,$revCommit);
4689 # error recovery: nothing found:
4690 print "E Failed to find $filename version=$revision\n";
4691 $log->warning("failed get $revision");
4692 return $meta;
4695 else
4697 my($revCommit)=$self->lookupCommitRef($revision);
4698 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4700 return $self->getMetaFromCommithash($filename,$revCommit);
4703 # error recovery: fall back on head version below
4704 print "E Failed to find $filename version=$revision\n";
4705 $log->warning("failed get $revision");
4706 undef $revision; # Allow fallback
4710 if(!defined($revision))
4712 my $db_query;
4713 $db_query = $self->{dbh}->prepare_cached(
4714 "SELECT * FROM $tablename_head WHERE name=?",{},1);
4715 $db_query->execute($filename);
4716 $meta = $db_query->fetchrow_hashref;
4719 if($meta)
4721 $meta->{revision} = "1.$meta->{revision}";
4723 return $meta;
4726 sub getMetaFromCommithash
4728 my $self = shift;
4729 my $filename = shift;
4730 my $revCommit = shift;
4732 # NOTE: This function doesn't scale well (lots of forks), especially
4733 # if you have many files that have not been modified for many commits
4734 # (each git-rev-parse redoes a lot of work for each file
4735 # that theoretically could be done in parallel by smarter
4736 # graph traversal).
4738 # TODO: Possible optimization strategies:
4739 # - Solve the issue of assigning and remembering "real" CVS
4740 # revision numbers for branches, and ensure the
4741 # data structure can do this efficiently. Perhaps something
4742 # similar to "git notes", and carefully structured to take
4743 # advantage same-sha1-is-same-contents, to roll the same
4744 # unmodified subdirectory data onto multiple commits?
4745 # - Write and use a C tool that is like git-blame, but
4746 # operates on multiple files with file granularity, instead
4747 # of one file with line granularity. Cache
4748 # most-recently-modified in $self->{commitRefCache}{$revCommit}.
4749 # Try to be intelligent about how many files we do with
4750 # one fork (perhaps one directory at a time, without recursion,
4751 # and/or include directory as one line item, recurse from here
4752 # instead of in C tool?).
4753 # - Perhaps we could ask the DB for (filename,fileHash),
4754 # and just guess that it is correct (that the file hadn't
4755 # changed between $revCommit and the found commit, then
4756 # changed back, confusing anything trying to interpret
4757 # history). Probably need to add another index to revisions
4758 # DB table for this.
4759 # - NOTE: Trying to store all (commit,file) keys in DB [to
4760 # find "lastModfiedCommit] (instead of
4761 # just files that changed in each commit as we do now) is
4762 # probably not practical from a disk space perspective.
4764 # Does the file exist in $revCommit?
4765 # TODO: Include file hash in dirmap cache.
4766 my($dirMap)=$self->getRevisionDirMap($revCommit);
4767 my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
4768 if(!defined($dir))
4770 $dir="";
4772 if( !defined($dirMap->{$dir}) ||
4773 !defined($dirMap->{$dir}{$filename}) )
4775 my($fileHash)="deleted";
4777 my($retVal)={};
4778 $retVal->{name}=$filename;
4779 $retVal->{filehash}=$fileHash;
4781 # not needed and difficult to compute:
4782 $retVal->{revision}="0"; # $revision;
4783 $retVal->{commithash}=$revCommit;
4784 #$retVal->{author}=$commit->{author};
4785 #$retVal->{modified}=convertToCvsDate($commit->{date});
4786 #$retVal->{mode}=convertToDbMode($mode);
4788 return $retVal;
4791 my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
4792 chomp $fileHash;
4793 if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4795 die "Invalid fileHash '$fileHash' looking up"
4796 ." '$revCommit:$filename'\n";
4799 # information about most recent commit to modify $filename:
4800 open(my $gitLogPipe, '-|', 'git', 'rev-list',
4801 '--max-count=1', '--pretty', '--parents',
4802 $revCommit, '--', $filename)
4803 or die "Cannot call git-rev-list: $!";
4804 my @commits=readCommits($gitLogPipe);
4805 close $gitLogPipe;
4806 if(scalar(@commits)!=1)
4808 die "Can't find most recent commit changing $filename\n";
4810 my($commit)=$commits[0];
4811 if( !defined($commit) || !defined($commit->{hash}) )
4813 return undef;
4816 # does this (commit,file) have a real assigned CVS revision number?
4817 my $tablename_rev = $self->tablename("revision");
4818 my $db_query;
4819 $db_query = $self->{dbh}->prepare_cached(
4820 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4821 {},1);
4822 $db_query->execute($filename, $commit->{hash});
4823 my($meta)=$db_query->fetchrow_hashref;
4824 if($meta)
4826 $meta->{revision} = "1.$meta->{revision}";
4827 return $meta;
4830 # fall back on special revision number
4831 my($revision)=$commit->{hash};
4832 $revision=~s/(..)/'.' . (hex($1)+100)/eg;
4833 $revision="2.1.1.2000$revision";
4835 # meta data about $filename:
4836 open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
4837 $commit->{hash}, '--', $filename)
4838 or die("Cannot call git-ls-tree : $!");
4839 local $/ = "\0";
4840 my $line;
4841 $line=<$filePipe>;
4842 if(defined(<$filePipe>))
4844 die "Expected only a single file for git-ls-tree $filename\n";
4846 close $filePipe;
4848 chomp $line;
4849 unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4851 die("Couldn't process git-ls-tree line : $line\n");
4853 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4855 # save result:
4856 my($retVal)={};
4857 $retVal->{name}=$filename;
4858 $retVal->{revision}=$revision;
4859 $retVal->{filehash}=$fileHash;
4860 $retVal->{commithash}=$revCommit;
4861 $retVal->{author}=$commit->{author};
4862 $retVal->{modified}=convertToCvsDate($commit->{date});
4863 $retVal->{mode}=convertToDbMode($mode);
4865 return $retVal;
4868 =head2 lookupCommitRef
4870 Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches
4871 the result so looking it up again is fast.
4873 =cut
4875 sub lookupCommitRef
4877 my $self = shift;
4878 my $ref = shift;
4880 my $commitHash = $self->{commitRefCache}{$ref};
4881 if(defined($commitHash))
4883 return $commitHash;
4886 $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
4887 $self->unescapeRefName($ref));
4888 $commitHash=~s/\s*$//;
4889 if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4891 $commitHash=undef;
4894 if( defined($commitHash) )
4896 my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
4897 if( ! ($type=~/^commit\s*$/ ) )
4899 $commitHash=undef;
4902 if(defined($commitHash))
4904 $self->{commitRefCache}{$ref}=$commitHash;
4906 return $commitHash;
4909 =head2 clearCommitRefCaches
4911 Clears cached commit cache (sha1's for various tags/abbeviations/etc),
4912 and related caches.
4914 =cut
4916 sub clearCommitRefCaches
4918 my $self = shift;
4919 $self->{commitRefCache} = {};
4920 $self->{revisionDirMapCache} = undef;
4921 $self->{gethead_cache} = undef;
4924 =head2 commitmessage
4926 this function takes a commithash and returns the commit message for that commit
4928 =cut
4929 sub commitmessage
4931 my $self = shift;
4932 my $commithash = shift;
4933 my $tablename = $self->tablename("commitmsgs");
4935 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
4937 my $db_query;
4938 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4939 $db_query->execute($commithash);
4941 my ( $message ) = $db_query->fetchrow_array;
4943 if ( defined ( $message ) )
4945 $message .= " " if ( $message =~ /\n$/ );
4946 return $message;
4949 my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
4950 shift @lines while ( $lines[0] =~ /\S/ );
4951 $message = join("",@lines);
4952 $message .= " " if ( $message =~ /\n$/ );
4953 return $message;
4956 =head2 gethistorydense
4958 This function takes a filename (with path) argument and returns an arrayofarrays
4959 containing revision,filehash,commithash ordered by revision descending.
4961 This version of gethistory skips deleted entries -- so it is useful for annotate.
4962 The 'dense' part is a reference to a '--dense' option available for git-rev-list
4963 and other git tools that depend on it.
4965 See also getlog().
4967 =cut
4968 sub gethistorydense
4970 my $self = shift;
4971 my $filename = shift;
4972 my $tablename = $self->tablename("revision");
4974 my $db_query;
4975 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
4976 $db_query->execute($filename);
4978 my $result = $db_query->fetchall_arrayref;
4980 my $i;
4981 for($i=0 ; $i<scalar(@$result) ; $i++)
4983 $result->[$i][0]="1." . $result->[$i][0];
4986 return $result;
4989 =head2 escapeRefName
4991 Apply an escape mechanism to compensate for characters that
4992 git ref names can have that CVS tags can not.
4994 =cut
4995 sub escapeRefName
4997 my($self,$refName)=@_;
4999 # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
5000 # many contexts it can also be a CVS revision number).
5002 # Git tags commonly use '/' and '.' as well, but also handle
5003 # anything else just in case:
5005 # = "_-s-" For '/'.
5006 # = "_-p-" For '.'.
5007 # = "_-u-" For underscore, in case someone wants a literal "_-" in
5008 # a tag name.
5009 # = "_-xx-" Where "xx" is the hexadecimal representation of the
5010 # desired ASCII character byte. (for anything else)
5012 if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
5014 $refName=~s/_-/_-u--/g;
5015 $refName=~s/\./_-p-/g;
5016 $refName=~s%/%_-s-%g;
5017 $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
5021 =head2 unescapeRefName
5023 Undo an escape mechanism to compensate for characters that
5024 git ref names can have that CVS tags can not.
5026 =cut
5027 sub unescapeRefName
5029 my($self,$refName)=@_;
5031 # see escapeRefName() for description of escape mechanism.
5033 $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
5035 # allowed tag names
5036 # TODO: Perhaps use git check-ref-format, with an in-process cache of
5037 # validated names?
5038 if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
5039 ( $refName=~m%[/.]$% ) ||
5040 ( $refName=~/\.lock$/ ) ||
5041 ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching }
5043 # Error:
5044 $log->warn("illegal refName: $refName");
5045 $refName=undef;
5047 return $refName;
5050 sub unescapeRefNameChar
5052 my($char)=@_;
5054 if($char eq "s")
5056 $char="/";
5058 elsif($char eq "p")
5060 $char=".";
5062 elsif($char eq "u")
5064 $char="_";
5066 elsif($char=~/^[0-9a-f][0-9a-f]$/)
5068 $char=chr(hex($char));
5070 else
5072 # Error case: Maybe it has come straight from user, and
5073 # wasn't supposed to be escaped? Restore it the way we got it:
5074 $char="_-$char-";
5077 return $char;
5080 =head2 in_array()
5082 from Array::PAT - mimics the in_array() function
5083 found in PHP. Yuck but works for small arrays.
5085 =cut
5086 sub in_array
5088 my ($check, @array) = @_;
5089 my $retval = 0;
5090 foreach my $test (@array){
5091 if($check eq $test){
5092 $retval = 1;
5095 return $retval;
5098 =head2 mangle_dirname
5100 create a string from a directory name that is suitable to use as
5101 part of a filename, mainly by converting all chars except \w.- to _
5103 =cut
5104 sub mangle_dirname {
5105 my $dirname = shift;
5106 return unless defined $dirname;
5108 $dirname =~ s/[^\w.-]/_/g;
5110 return $dirname;
5113 =head2 mangle_tablename
5115 create a string from a that is suitable to use as part of an SQL table
5116 name, mainly by converting all chars except \w to _
5118 =cut
5119 sub mangle_tablename {
5120 my $tablename = shift;
5121 return unless defined $tablename;
5123 $tablename =~ s/[^\w_]/_/g;
5125 return $tablename;