Merge branch 'kc/maint-diff-bwi-fix'
[git/mingw.git] / git-cvsserver.perl
blobfef7faf33947a87ded0e8a2d9fd6f1af6047d951
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@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
20 use bytes;
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Path qw/rmtree/;
25 use File::Basename;
26 use Getopt::Long qw(:config require_order no_ignore_case);
28 my $VERSION = '@@GIT_VERSION@@';
30 my $log = GITCVS::log->new();
31 my $cfg;
33 my $DATE_LIST = {
34 Jan => "01",
35 Feb => "02",
36 Mar => "03",
37 Apr => "04",
38 May => "05",
39 Jun => "06",
40 Jul => "07",
41 Aug => "08",
42 Sep => "09",
43 Oct => "10",
44 Nov => "11",
45 Dec => "12",
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
49 $| = 1;
51 #### Definition and mappings of functions ####
53 my $methods = {
54 'Root' => \&req_Root,
55 'Valid-responses' => \&req_Validresponses,
56 'valid-requests' => \&req_validrequests,
57 'Directory' => \&req_Directory,
58 'Entry' => \&req_Entry,
59 'Modified' => \&req_Modified,
60 'Unchanged' => \&req_Unchanged,
61 'Questionable' => \&req_Questionable,
62 'Argument' => \&req_Argument,
63 'Argumentx' => \&req_Argument,
64 'expand-modules' => \&req_expandmodules,
65 'add' => \&req_add,
66 'remove' => \&req_remove,
67 'co' => \&req_co,
68 'update' => \&req_update,
69 'ci' => \&req_ci,
70 'diff' => \&req_diff,
71 'log' => \&req_log,
72 'rlog' => \&req_log,
73 'tag' => \&req_CATCHALL,
74 'status' => \&req_status,
75 'admin' => \&req_CATCHALL,
76 'history' => \&req_CATCHALL,
77 'watchers' => \&req_EMPTY,
78 'editors' => \&req_EMPTY,
79 'annotate' => \&req_annotate,
80 'Global_option' => \&req_Globaloption,
81 #'annotate' => \&req_CATCHALL,
84 ##############################################
87 # $state holds all the bits of information the clients sends us that could
88 # potentially be useful when it comes to actually _doing_ something.
89 my $state = { prependdir => '' };
91 # Work is for managing temporary working directory
92 my $work =
94 state => undef, # undef, 1 (empty), 2 (with stuff)
95 workDir => undef,
96 index => undef,
97 emptyDir => undef,
98 tmpDir => undef
101 $log->info("--------------- STARTING -----------------");
103 my $usage =
104 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
105 " --base-path <path> : Prepend to requested CVSROOT\n".
106 " --strict-paths : Don't allow recursing into subdirectories\n".
107 " --export-all : Don't check for gitcvs.enabled in config\n".
108 " --version, -V : Print version information and exit\n".
109 " --help, -h, -H : Print usage information and exit\n".
110 "\n".
111 "<directory> ... is a list of allowed directories. If no directories\n".
112 "are given, all are allowed. This is an additional restriction, gitcvs\n".
113 "access still needs to be enabled by the gitcvs.enabled config option.\n";
115 my @opts = ( 'help|h|H', 'version|V',
116 'base-path=s', 'strict-paths', 'export-all' );
117 GetOptions( $state, @opts )
118 or die $usage;
120 if ($state->{version}) {
121 print "git-cvsserver version $VERSION\n";
122 exit;
124 if ($state->{help}) {
125 print $usage;
126 exit;
129 my $TEMP_DIR = tempdir( CLEANUP => 1 );
130 $log->debug("Temporary directory is '$TEMP_DIR'");
132 $state->{method} = 'ext';
133 if (@ARGV) {
134 if ($ARGV[0] eq 'pserver') {
135 $state->{method} = 'pserver';
136 shift @ARGV;
137 } elsif ($ARGV[0] eq 'server') {
138 shift @ARGV;
142 # everything else is a directory
143 $state->{allowed_roots} = [ @ARGV ];
145 # don't export the whole system unless the users requests it
146 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
147 die "--export-all can only be used together with an explicit whitelist\n";
150 # if we are called with a pserver argument,
151 # deal with the authentication cat before entering the
152 # main loop
153 if ($state->{method} eq 'pserver') {
154 my $line = <STDIN>; chomp $line;
155 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
156 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
158 my $request = $1;
159 $line = <STDIN>; chomp $line;
160 unless (req_Root('root', $line)) { # reuse Root
161 print "E Invalid root $line \n";
162 exit 1;
164 $line = <STDIN>; chomp $line;
165 unless ($line eq 'anonymous') {
166 print "E Only anonymous user allowed via pserver\n";
167 print "I HATE YOU\n";
168 exit 1;
170 $line = <STDIN>; chomp $line; # validate the password?
171 $line = <STDIN>; chomp $line;
172 unless ($line eq "END $request REQUEST") {
173 die "E Do not understand $line -- expecting END $request REQUEST\n";
175 print "I LOVE YOU\n";
176 exit if $request eq 'VERIFICATION'; # cvs login
177 # and now back to our regular programme...
180 # Keep going until the client closes the connection
181 while (<STDIN>)
183 chomp;
185 # Check to see if we've seen this method, and call appropriate function.
186 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
188 # use the $methods hash to call the appropriate sub for this command
189 #$log->info("Method : $1");
190 &{$methods->{$1}}($1,$2);
191 } else {
192 # log fatal because we don't understand this function. If this happens
193 # we're fairly screwed because we don't know if the client is expecting
194 # a response. If it is, the client will hang, we'll hang, and the whole
195 # thing will be custard.
196 $log->fatal("Don't understand command $_\n");
197 die("Unknown command $_");
201 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
202 $log->info("--------------- FINISH -----------------");
204 chdir '/';
205 exit 0;
207 # Magic catchall method.
208 # This is the method that will handle all commands we haven't yet
209 # implemented. It simply sends a warning to the log file indicating a
210 # command that hasn't been implemented has been invoked.
211 sub req_CATCHALL
213 my ( $cmd, $data ) = @_;
214 $log->warn("Unhandled command : req_$cmd : $data");
217 # This method invariably succeeds with an empty response.
218 sub req_EMPTY
220 print "ok\n";
223 # Root pathname \n
224 # Response expected: no. Tell the server which CVSROOT to use. Note that
225 # pathname is a local directory and not a fully qualified CVSROOT variable.
226 # pathname must already exist; if creating a new root, use the init
227 # request, not Root. pathname does not include the hostname of the server,
228 # how to access the server, etc.; by the time the CVS protocol is in use,
229 # connection, authentication, etc., are already taken care of. The Root
230 # request must be sent only once, and it must be sent before any requests
231 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
232 sub req_Root
234 my ( $cmd, $data ) = @_;
235 $log->debug("req_Root : $data");
237 unless ($data =~ m#^/#) {
238 print "error 1 Root must be an absolute pathname\n";
239 return 0;
242 my $cvsroot = $state->{'base-path'} || '';
243 $cvsroot =~ s#/+$##;
244 $cvsroot .= $data;
246 if ($state->{CVSROOT}
247 && ($state->{CVSROOT} ne $cvsroot)) {
248 print "error 1 Conflicting roots specified\n";
249 return 0;
252 $state->{CVSROOT} = $cvsroot;
254 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
256 if (@{$state->{allowed_roots}}) {
257 my $allowed = 0;
258 foreach my $dir (@{$state->{allowed_roots}}) {
259 next unless $dir =~ m#^/#;
260 $dir =~ s#/+$##;
261 if ($state->{'strict-paths'}) {
262 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
263 $allowed = 1;
264 last;
266 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
267 $allowed = 1;
268 last;
272 unless ($allowed) {
273 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
274 print "E \n";
275 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
276 return 0;
280 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
281 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
282 print "E \n";
283 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
284 return 0;
287 my @gitvars = `git-config -l`;
288 if ($?) {
289 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
290 print "E \n";
291 print "error 1 - problem executing git-config\n";
292 return 0;
294 foreach my $line ( @gitvars )
296 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
297 unless ($2) {
298 $cfg->{$1}{$3} = $4;
299 } else {
300 $cfg->{$1}{$2}{$3} = $4;
304 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
305 || $cfg->{gitcvs}{enabled});
306 unless ($state->{'export-all'} ||
307 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
308 print "E GITCVS emulation needs to be enabled on this repo\n";
309 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
310 print "E \n";
311 print "error 1 GITCVS emulation disabled\n";
312 return 0;
315 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
316 if ( $logfile )
318 $log->setfile($logfile);
319 } else {
320 $log->nofile();
323 return 1;
326 # Global_option option \n
327 # Response expected: no. Transmit one of the global options `-q', `-Q',
328 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
329 # variations (such as combining of options) are allowed. For graceful
330 # handling of valid-requests, it is probably better to make new global
331 # options separate requests, rather than trying to add them to this
332 # request.
333 sub req_Globaloption
335 my ( $cmd, $data ) = @_;
336 $log->debug("req_Globaloption : $data");
337 $state->{globaloptions}{$data} = 1;
340 # Valid-responses request-list \n
341 # Response expected: no. Tell the server what responses the client will
342 # accept. request-list is a space separated list of tokens.
343 sub req_Validresponses
345 my ( $cmd, $data ) = @_;
346 $log->debug("req_Validresponses : $data");
348 # TODO : re-enable this, currently it's not particularly useful
349 #$state->{validresponses} = [ split /\s+/, $data ];
352 # valid-requests \n
353 # Response expected: yes. Ask the server to send back a Valid-requests
354 # response.
355 sub req_validrequests
357 my ( $cmd, $data ) = @_;
359 $log->debug("req_validrequests");
361 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
362 $log->debug("SEND : ok");
364 print "Valid-requests " . join(" ",keys %$methods) . "\n";
365 print "ok\n";
368 # Directory local-directory \n
369 # Additional data: repository \n. Response expected: no. Tell the server
370 # what directory to use. The repository should be a directory name from a
371 # previous server response. Note that this both gives a default for Entry
372 # and Modified and also for ci and the other commands; normal usage is to
373 # send Directory for each directory in which there will be an Entry or
374 # Modified, and then a final Directory for the original directory, then the
375 # command. The local-directory is relative to the top level at which the
376 # command is occurring (i.e. the last Directory which is sent before the
377 # command); to indicate that top level, `.' should be sent for
378 # local-directory.
379 sub req_Directory
381 my ( $cmd, $data ) = @_;
383 my $repository = <STDIN>;
384 chomp $repository;
387 $state->{localdir} = $data;
388 $state->{repository} = $repository;
389 $state->{path} = $repository;
390 $state->{path} =~ s/^$state->{CVSROOT}\///;
391 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
392 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
394 $state->{directory} = $state->{localdir};
395 $state->{directory} = "" if ( $state->{directory} eq "." );
396 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
398 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
400 $log->info("Setting prepend to '$state->{path}'");
401 $state->{prependdir} = $state->{path};
402 foreach my $entry ( keys %{$state->{entries}} )
404 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
405 delete $state->{entries}{$entry};
409 if ( defined ( $state->{prependdir} ) )
411 $log->debug("Prepending '$state->{prependdir}' to state|directory");
412 $state->{directory} = $state->{prependdir} . $state->{directory}
414 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
417 # Entry entry-line \n
418 # Response expected: no. Tell the server what version of a file is on the
419 # local machine. The name in entry-line is a name relative to the directory
420 # most recently specified with Directory. If the user is operating on only
421 # some files in a directory, Entry requests for only those files need be
422 # included. If an Entry request is sent without Modified, Is-modified, or
423 # Unchanged, it means the file is lost (does not exist in the working
424 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
425 # are sent for the same file, Entry must be sent first. For a given file,
426 # one can send Modified, Is-modified, or Unchanged, but not more than one
427 # of these three.
428 sub req_Entry
430 my ( $cmd, $data ) = @_;
432 #$log->debug("req_Entry : $data");
434 my @data = split(/\//, $data);
436 $state->{entries}{$state->{directory}.$data[1]} = {
437 revision => $data[2],
438 conflict => $data[3],
439 options => $data[4],
440 tag_or_date => $data[5],
443 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
446 # Questionable filename \n
447 # Response expected: no. Additional data: no. Tell the server to check
448 # whether filename should be ignored, and if not, next time the server
449 # sends responses, send (in a M response) `?' followed by the directory and
450 # filename. filename must not contain `/'; it needs to be a file in the
451 # directory named by the most recent Directory request.
452 sub req_Questionable
454 my ( $cmd, $data ) = @_;
456 $log->debug("req_Questionable : $data");
457 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
460 # add \n
461 # Response expected: yes. Add a file or directory. This uses any previous
462 # Argument, Directory, Entry, or Modified requests, if they have been sent.
463 # The last Directory sent specifies the working directory at the time of
464 # the operation. To add a directory, send the directory to be added using
465 # Directory and Argument requests.
466 sub req_add
468 my ( $cmd, $data ) = @_;
470 argsplit("add");
472 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
473 $updater->update();
475 argsfromdir($updater);
477 my $addcount = 0;
479 foreach my $filename ( @{$state->{args}} )
481 $filename = filecleanup($filename);
483 my $meta = $updater->getmeta($filename);
484 my $wrev = revparse($filename);
486 if ($wrev && $meta && ($wrev < 0))
488 # previously removed file, add back
489 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
491 print "MT +updated\n";
492 print "MT text U \n";
493 print "MT fname $filename\n";
494 print "MT newline\n";
495 print "MT -updated\n";
497 unless ( $state->{globaloptions}{-n} )
499 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
501 print "Created $dirpart\n";
502 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
504 # this is an "entries" line
505 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
506 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
507 print "/$filepart/1.$meta->{revision}//$kopts/\n";
508 # permissions
509 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
510 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
511 # transmit file
512 transmitfile($meta->{filehash});
515 next;
518 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
520 print "E cvs add: nothing known about `$filename'\n";
521 next;
523 # TODO : check we're not squashing an already existing file
524 if ( defined ( $state->{entries}{$filename}{revision} ) )
526 print "E cvs add: `$filename' has already been entered\n";
527 next;
530 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
532 print "E cvs add: scheduling file `$filename' for addition\n";
534 print "Checked-in $dirpart\n";
535 print "$filename\n";
536 my $kopts = kopts_from_path($filename,"file",
537 $state->{entries}{$filename}{modified_filename});
538 print "/$filepart/0//$kopts/\n";
540 my $requestedKopts = $state->{opt}{k};
541 if(defined($requestedKopts))
543 $requestedKopts = "-k$requestedKopts";
545 else
547 $requestedKopts = "";
549 if( $kopts ne $requestedKopts )
551 $log->warn("Ignoring requested -k='$requestedKopts'"
552 . " for '$filename'; detected -k='$kopts' instead");
553 #TODO: Also have option to send warning to user?
556 $addcount++;
559 if ( $addcount == 1 )
561 print "E cvs add: use `cvs commit' to add this file permanently\n";
563 elsif ( $addcount > 1 )
565 print "E cvs add: use `cvs commit' to add these files permanently\n";
568 print "ok\n";
571 # remove \n
572 # Response expected: yes. Remove a file. This uses any previous Argument,
573 # Directory, Entry, or Modified requests, if they have been sent. The last
574 # Directory sent specifies the working directory at the time of the
575 # operation. Note that this request does not actually do anything to the
576 # repository; the only effect of a successful remove request is to supply
577 # the client with a new entries line containing `-' to indicate a removed
578 # file. In fact, the client probably could perform this operation without
579 # contacting the server, although using remove may cause the server to
580 # perform a few more checks. The client sends a subsequent ci request to
581 # actually record the removal in the repository.
582 sub req_remove
584 my ( $cmd, $data ) = @_;
586 argsplit("remove");
588 # Grab a handle to the SQLite db and do any necessary updates
589 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
590 $updater->update();
592 #$log->debug("add state : " . Dumper($state));
594 my $rmcount = 0;
596 foreach my $filename ( @{$state->{args}} )
598 $filename = filecleanup($filename);
600 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
602 print "E cvs remove: file `$filename' still in working directory\n";
603 next;
606 my $meta = $updater->getmeta($filename);
607 my $wrev = revparse($filename);
609 unless ( defined ( $wrev ) )
611 print "E cvs remove: nothing known about `$filename'\n";
612 next;
615 if ( defined($wrev) and $wrev < 0 )
617 print "E cvs remove: file `$filename' already scheduled for removal\n";
618 next;
621 unless ( $wrev == $meta->{revision} )
623 # TODO : not sure if the format of this message is quite correct.
624 print "E cvs remove: Up to date check failed for `$filename'\n";
625 next;
629 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
631 print "E cvs remove: scheduling `$filename' for removal\n";
633 print "Checked-in $dirpart\n";
634 print "$filename\n";
635 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
636 print "/$filepart/-1.$wrev//$kopts/\n";
638 $rmcount++;
641 if ( $rmcount == 1 )
643 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
645 elsif ( $rmcount > 1 )
647 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
650 print "ok\n";
653 # Modified filename \n
654 # Response expected: no. Additional data: mode, \n, file transmission. Send
655 # the server a copy of one locally modified file. filename is a file within
656 # the most recent directory sent with Directory; it must not contain `/'.
657 # If the user is operating on only some files in a directory, only those
658 # files need to be included. This can also be sent without Entry, if there
659 # is no entry for the file.
660 sub req_Modified
662 my ( $cmd, $data ) = @_;
664 my $mode = <STDIN>;
665 defined $mode
666 or (print "E end of file reading mode for $data\n"), return;
667 chomp $mode;
668 my $size = <STDIN>;
669 defined $size
670 or (print "E end of file reading size of $data\n"), return;
671 chomp $size;
673 # Grab config information
674 my $blocksize = 8192;
675 my $bytesleft = $size;
676 my $tmp;
678 # Get a filehandle/name to write it to
679 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
681 # Loop over file data writing out to temporary file.
682 while ( $bytesleft )
684 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
685 read STDIN, $tmp, $blocksize;
686 print $fh $tmp;
687 $bytesleft -= $blocksize;
690 close $fh
691 or (print "E failed to write temporary, $filename: $!\n"), return;
693 # Ensure we have something sensible for the file mode
694 if ( $mode =~ /u=(\w+)/ )
696 $mode = $1;
697 } else {
698 $mode = "rw";
701 # Save the file data in $state
702 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
703 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
704 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
705 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
707 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
710 # Unchanged filename \n
711 # Response expected: no. Tell the server that filename has not been
712 # modified in the checked out directory. The filename is a file within the
713 # most recent directory sent with Directory; it must not contain `/'.
714 sub req_Unchanged
716 my ( $cmd, $data ) = @_;
718 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
720 #$log->debug("req_Unchanged : $data");
723 # Argument text \n
724 # Response expected: no. Save argument for use in a subsequent command.
725 # Arguments accumulate until an argument-using command is given, at which
726 # point they are forgotten.
727 # Argumentx text \n
728 # Response expected: no. Append \n followed by text to the current argument
729 # being saved.
730 sub req_Argument
732 my ( $cmd, $data ) = @_;
734 # Argumentx means: append to last Argument (with a newline in front)
736 $log->debug("$cmd : $data");
738 if ( $cmd eq 'Argumentx') {
739 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
740 } else {
741 push @{$state->{arguments}}, $data;
745 # expand-modules \n
746 # Response expected: yes. Expand the modules which are specified in the
747 # arguments. Returns the data in Module-expansion responses. Note that the
748 # server can assume that this is checkout or export, not rtag or rdiff; the
749 # latter do not access the working directory and thus have no need to
750 # expand modules on the client side. Expand may not be the best word for
751 # what this request does. It does not necessarily tell you all the files
752 # contained in a module, for example. Basically it is a way of telling you
753 # which working directories the server needs to know about in order to
754 # handle a checkout of the specified modules. For example, suppose that the
755 # server has a module defined by
756 # aliasmodule -a 1dir
757 # That is, one can check out aliasmodule and it will take 1dir in the
758 # repository and check it out to 1dir in the working directory. Now suppose
759 # the client already has this module checked out and is planning on using
760 # the co request to update it. Without using expand-modules, the client
761 # would have two bad choices: it could either send information about all
762 # working directories under the current directory, which could be
763 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
764 # stands for 1dir, and neglect to send information for 1dir, which would
765 # lead to incorrect operation. With expand-modules, the client would first
766 # ask for the module to be expanded:
767 sub req_expandmodules
769 my ( $cmd, $data ) = @_;
771 argsplit();
773 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
775 unless ( ref $state->{arguments} eq "ARRAY" )
777 print "ok\n";
778 return;
781 foreach my $module ( @{$state->{arguments}} )
783 $log->debug("SEND : Module-expansion $module");
784 print "Module-expansion $module\n";
787 print "ok\n";
788 statecleanup();
791 # co \n
792 # Response expected: yes. Get files from the repository. This uses any
793 # previous Argument, Directory, Entry, or Modified requests, if they have
794 # been sent. Arguments to this command are module names; the client cannot
795 # know what directories they correspond to except by (1) just sending the
796 # co request, and then seeing what directory names the server sends back in
797 # its responses, and (2) the expand-modules request.
798 sub req_co
800 my ( $cmd, $data ) = @_;
802 argsplit("co");
804 # Provide list of modules, if -c was used.
805 if (exists $state->{opt}{c}) {
806 my $showref = `git show-ref --heads`;
807 for my $line (split '\n', $showref) {
808 if ( $line =~ m% refs/heads/(.*)$% ) {
809 print "M $1\t$1\n";
812 print "ok\n";
813 return 1;
816 my $module = $state->{args}[0];
817 $state->{module} = $module;
818 my $checkout_path = $module;
820 # use the user specified directory if we're given it
821 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
823 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
825 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
827 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
829 # Grab a handle to the SQLite db and do any necessary updates
830 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
831 $updater->update();
833 $checkout_path =~ s|/$||; # get rid of trailing slashes
835 # Eclipse seems to need the Clear-sticky command
836 # to prepare the 'Entries' file for the new directory.
837 print "Clear-sticky $checkout_path/\n";
838 print $state->{CVSROOT} . "/$module/\n";
839 print "Clear-static-directory $checkout_path/\n";
840 print $state->{CVSROOT} . "/$module/\n";
841 print "Clear-sticky $checkout_path/\n"; # yes, twice
842 print $state->{CVSROOT} . "/$module/\n";
843 print "Template $checkout_path/\n";
844 print $state->{CVSROOT} . "/$module/\n";
845 print "0\n";
847 # instruct the client that we're checking out to $checkout_path
848 print "E cvs checkout: Updating $checkout_path\n";
850 my %seendirs = ();
851 my $lastdir ='';
853 # recursive
854 sub prepdir {
855 my ($dir, $repodir, $remotedir, $seendirs) = @_;
856 my $parent = dirname($dir);
857 $dir =~ s|/+$||;
858 $repodir =~ s|/+$||;
859 $remotedir =~ s|/+$||;
860 $parent =~ s|/+$||;
861 $log->debug("announcedir $dir, $repodir, $remotedir" );
863 if ($parent eq '.' || $parent eq './') {
864 $parent = '';
866 # recurse to announce unseen parents first
867 if (length($parent) && !exists($seendirs->{$parent})) {
868 prepdir($parent, $repodir, $remotedir, $seendirs);
870 # Announce that we are going to modify at the parent level
871 if ($parent) {
872 print "E cvs checkout: Updating $remotedir/$parent\n";
873 } else {
874 print "E cvs checkout: Updating $remotedir\n";
876 print "Clear-sticky $remotedir/$parent/\n";
877 print "$repodir/$parent/\n";
879 print "Clear-static-directory $remotedir/$dir/\n";
880 print "$repodir/$dir/\n";
881 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
882 print "$repodir/$parent/\n";
883 print "Template $remotedir/$dir/\n";
884 print "$repodir/$dir/\n";
885 print "0\n";
887 $seendirs->{$dir} = 1;
890 foreach my $git ( @{$updater->gethead} )
892 # Don't want to check out deleted files
893 next if ( $git->{filehash} eq "deleted" );
895 my $fullName = $git->{name};
896 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
898 if (length($git->{dir}) && $git->{dir} ne './'
899 && $git->{dir} ne $lastdir ) {
900 unless (exists($seendirs{$git->{dir}})) {
901 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
902 $checkout_path, \%seendirs);
903 $lastdir = $git->{dir};
904 $seendirs{$git->{dir}} = 1;
906 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
909 # modification time of this file
910 print "Mod-time $git->{modified}\n";
912 # print some information to the client
913 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
915 print "M U $checkout_path/$git->{dir}$git->{name}\n";
916 } else {
917 print "M U $checkout_path/$git->{name}\n";
920 # instruct client we're sending a file to put in this path
921 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
923 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
925 # this is an "entries" line
926 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
927 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
928 # permissions
929 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
931 # transmit file
932 transmitfile($git->{filehash});
935 print "ok\n";
937 statecleanup();
940 # update \n
941 # Response expected: yes. Actually do a cvs update command. This uses any
942 # previous Argument, Directory, Entry, or Modified requests, if they have
943 # been sent. The last Directory sent specifies the working directory at the
944 # time of the operation. The -I option is not used--files which the client
945 # can decide whether to ignore are not mentioned and the client sends the
946 # Questionable request for others.
947 sub req_update
949 my ( $cmd, $data ) = @_;
951 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
953 argsplit("update");
956 # It may just be a client exploring the available heads/modules
957 # in that case, list them as top level directories and leave it
958 # at that. Eclipse uses this technique to offer you a list of
959 # projects (heads in this case) to checkout.
961 if ($state->{module} eq '') {
962 my $showref = `git show-ref --heads`;
963 print "E cvs update: Updating .\n";
964 for my $line (split '\n', $showref) {
965 if ( $line =~ m% refs/heads/(.*)$% ) {
966 print "E cvs update: New directory `$1'\n";
969 print "ok\n";
970 return 1;
974 # Grab a handle to the SQLite db and do any necessary updates
975 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
977 $updater->update();
979 argsfromdir($updater);
981 #$log->debug("update state : " . Dumper($state));
983 # foreach file specified on the command line ...
984 foreach my $filename ( @{$state->{args}} )
986 $filename = filecleanup($filename);
988 $log->debug("Processing file $filename");
990 # if we have a -C we should pretend we never saw modified stuff
991 if ( exists ( $state->{opt}{C} ) )
993 delete $state->{entries}{$filename}{modified_hash};
994 delete $state->{entries}{$filename}{modified_filename};
995 $state->{entries}{$filename}{unchanged} = 1;
998 my $meta;
999 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1001 $meta = $updater->getmeta($filename, $1);
1002 } else {
1003 $meta = $updater->getmeta($filename);
1006 # If -p was given, "print" the contents of the requested revision.
1007 if ( exists ( $state->{opt}{p} ) ) {
1008 if ( defined ( $meta->{revision} ) ) {
1009 $log->info("Printing '$filename' revision " . $meta->{revision});
1011 transmitfile($meta->{filehash}, { print => 1 });
1014 next;
1017 if ( ! defined $meta )
1019 $meta = {
1020 name => $filename,
1021 revision => 0,
1022 filehash => 'added'
1026 my $oldmeta = $meta;
1028 my $wrev = revparse($filename);
1030 # If the working copy is an old revision, lets get that version too for comparison.
1031 if ( defined($wrev) and $wrev != $meta->{revision} )
1033 $oldmeta = $updater->getmeta($filename, $wrev);
1036 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1038 # Files are up to date if the working copy and repo copy have the same revision,
1039 # and the working copy is unmodified _and_ the user hasn't specified -C
1040 next if ( defined ( $wrev )
1041 and defined($meta->{revision})
1042 and $wrev == $meta->{revision}
1043 and $state->{entries}{$filename}{unchanged}
1044 and not exists ( $state->{opt}{C} ) );
1046 # If the working copy and repo copy have the same revision,
1047 # but the working copy is modified, tell the client it's modified
1048 if ( defined ( $wrev )
1049 and defined($meta->{revision})
1050 and $wrev == $meta->{revision}
1051 and defined($state->{entries}{$filename}{modified_hash})
1052 and not exists ( $state->{opt}{C} ) )
1054 $log->info("Tell the client the file is modified");
1055 print "MT text M \n";
1056 print "MT fname $filename\n";
1057 print "MT newline\n";
1058 next;
1061 if ( $meta->{filehash} eq "deleted" )
1063 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1065 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1067 print "E cvs update: `$filename' is no longer in the repository\n";
1068 # Don't want to actually _DO_ the update if -n specified
1069 unless ( $state->{globaloptions}{-n} ) {
1070 print "Removed $dirpart\n";
1071 print "$filepart\n";
1074 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1075 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1076 or $meta->{filehash} eq 'added' )
1078 # normal update, just send the new revision (either U=Update,
1079 # or A=Add, or R=Remove)
1080 if ( defined($wrev) && $wrev < 0 )
1082 $log->info("Tell the client the file is scheduled for removal");
1083 print "MT text R \n";
1084 print "MT fname $filename\n";
1085 print "MT newline\n";
1086 next;
1088 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1090 $log->info("Tell the client the file is scheduled for addition");
1091 print "MT text A \n";
1092 print "MT fname $filename\n";
1093 print "MT newline\n";
1094 next;
1097 else {
1098 $log->info("Updating '$filename' to ".$meta->{revision});
1099 print "MT +updated\n";
1100 print "MT text U \n";
1101 print "MT fname $filename\n";
1102 print "MT newline\n";
1103 print "MT -updated\n";
1106 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1108 # Don't want to actually _DO_ the update if -n specified
1109 unless ( $state->{globaloptions}{-n} )
1111 if ( defined ( $wrev ) )
1113 # instruct client we're sending a file to put in this path as a replacement
1114 print "Update-existing $dirpart\n";
1115 $log->debug("Updating existing file 'Update-existing $dirpart'");
1116 } else {
1117 # instruct client we're sending a file to put in this path as a new file
1118 print "Clear-static-directory $dirpart\n";
1119 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1120 print "Clear-sticky $dirpart\n";
1121 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1123 $log->debug("Creating new file 'Created $dirpart'");
1124 print "Created $dirpart\n";
1126 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1128 # this is an "entries" line
1129 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1130 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1131 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1133 # permissions
1134 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1135 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1137 # transmit file
1138 transmitfile($meta->{filehash});
1140 } else {
1141 $log->info("Updating '$filename'");
1142 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1144 my $mergeDir = setupTmpDir();
1146 my $file_local = $filepart . ".mine";
1147 my $mergedFile = "$mergeDir/$file_local";
1148 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1149 my $file_old = $filepart . "." . $oldmeta->{revision};
1150 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1151 my $file_new = $filepart . "." . $meta->{revision};
1152 transmitfile($meta->{filehash}, { targetfile => $file_new });
1154 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1155 $log->info("Merging $file_local, $file_old, $file_new");
1156 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1158 $log->debug("Temporary directory for merge is $mergeDir");
1160 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1161 $return >>= 8;
1163 cleanupTmpDir();
1165 if ( $return == 0 )
1167 $log->info("Merged successfully");
1168 print "M M $filename\n";
1169 $log->debug("Merged $dirpart");
1171 # Don't want to actually _DO_ the update if -n specified
1172 unless ( $state->{globaloptions}{-n} )
1174 print "Merged $dirpart\n";
1175 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1176 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1177 my $kopts = kopts_from_path("$dirpart/$filepart",
1178 "file",$mergedFile);
1179 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1180 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1183 elsif ( $return == 1 )
1185 $log->info("Merged with conflicts");
1186 print "E cvs update: conflicts found in $filename\n";
1187 print "M C $filename\n";
1189 # Don't want to actually _DO_ the update if -n specified
1190 unless ( $state->{globaloptions}{-n} )
1192 print "Merged $dirpart\n";
1193 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1194 my $kopts = kopts_from_path("$dirpart/$filepart",
1195 "file",$mergedFile);
1196 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1199 else
1201 $log->warn("Merge failed");
1202 next;
1205 # Don't want to actually _DO_ the update if -n specified
1206 unless ( $state->{globaloptions}{-n} )
1208 # permissions
1209 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1210 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1212 # transmit file, format is single integer on a line by itself (file
1213 # size) followed by the file contents
1214 # TODO : we should copy files in blocks
1215 my $data = `cat $mergedFile`;
1216 $log->debug("File size : " . length($data));
1217 print length($data) . "\n";
1218 print $data;
1224 print "ok\n";
1227 sub req_ci
1229 my ( $cmd, $data ) = @_;
1231 argsplit("ci");
1233 #$log->debug("State : " . Dumper($state));
1235 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1237 if ( $state->{method} eq 'pserver')
1239 print "error 1 pserver access cannot commit\n";
1240 cleanupWorkTree();
1241 exit;
1244 if ( -e $state->{CVSROOT} . "/index" )
1246 $log->warn("file 'index' already exists in the git repository");
1247 print "error 1 Index already exists in git repo\n";
1248 cleanupWorkTree();
1249 exit;
1252 # Grab a handle to the SQLite db and do any necessary updates
1253 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1254 $updater->update();
1256 # Remember where the head was at the beginning.
1257 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1258 chomp $parenthash;
1259 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1260 print "error 1 pserver cannot find the current HEAD of module";
1261 cleanupWorkTree();
1262 exit;
1265 setupWorkTree($parenthash);
1267 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1269 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1271 my @committedfiles = ();
1272 my %oldmeta;
1274 # foreach file specified on the command line ...
1275 foreach my $filename ( @{$state->{args}} )
1277 my $committedfile = $filename;
1278 $filename = filecleanup($filename);
1280 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1282 my $meta = $updater->getmeta($filename);
1283 $oldmeta{$filename} = $meta;
1285 my $wrev = revparse($filename);
1287 my ( $filepart, $dirpart ) = filenamesplit($filename);
1289 # do a checkout of the file if it is part of this tree
1290 if ($wrev) {
1291 system('git-checkout-index', '-f', '-u', $filename);
1292 unless ($? == 0) {
1293 die "Error running git-checkout-index -f -u $filename : $!";
1297 my $addflag = 0;
1298 my $rmflag = 0;
1299 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1300 $addflag = 1 unless ( -e $filename );
1302 # Do up to date checking
1303 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1305 # fail everything if an up to date check fails
1306 print "error 1 Up to date check failed for $filename\n";
1307 cleanupWorkTree();
1308 exit;
1311 push @committedfiles, $committedfile;
1312 $log->info("Committing $filename");
1314 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1316 unless ( $rmflag )
1318 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1319 rename $state->{entries}{$filename}{modified_filename},$filename;
1321 # Calculate modes to remove
1322 my $invmode = "";
1323 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1325 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1326 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1329 if ( $rmflag )
1331 $log->info("Removing file '$filename'");
1332 unlink($filename);
1333 system("git-update-index", "--remove", $filename);
1335 elsif ( $addflag )
1337 $log->info("Adding file '$filename'");
1338 system("git-update-index", "--add", $filename);
1339 } else {
1340 $log->info("Updating file '$filename'");
1341 system("git-update-index", $filename);
1345 unless ( scalar(@committedfiles) > 0 )
1347 print "E No files to commit\n";
1348 print "ok\n";
1349 cleanupWorkTree();
1350 return;
1353 my $treehash = `git-write-tree`;
1354 chomp $treehash;
1356 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1358 # write our commit message out if we have one ...
1359 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1360 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1361 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1362 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1363 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1365 } else {
1366 print $msg_fh "\n\nvia git-CVS emulator\n";
1368 close $msg_fh;
1370 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1371 chomp($commithash);
1372 $log->info("Commit hash : $commithash");
1374 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1376 $log->warn("Commit failed (Invalid commit hash)");
1377 print "error 1 Commit failed (unknown reason)\n";
1378 cleanupWorkTree();
1379 exit;
1382 ### Emulate git-receive-pack by running hooks/update
1383 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1384 $parenthash, $commithash );
1385 if( -x $hook[0] ) {
1386 unless( system( @hook ) == 0 )
1388 $log->warn("Commit failed (update hook declined to update ref)");
1389 print "error 1 Commit failed (update hook declined)\n";
1390 cleanupWorkTree();
1391 exit;
1395 ### Update the ref
1396 if (system(qw(git update-ref -m), "cvsserver ci",
1397 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1398 $log->warn("update-ref for $state->{module} failed.");
1399 print "error 1 Cannot commit -- update first\n";
1400 cleanupWorkTree();
1401 exit;
1404 ### Emulate git-receive-pack by running hooks/post-receive
1405 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1406 if( -x $hook ) {
1407 open(my $pipe, "| $hook") || die "can't fork $!";
1409 local $SIG{PIPE} = sub { die 'pipe broke' };
1411 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1413 close $pipe || die "bad pipe: $! $?";
1416 ### Then hooks/post-update
1417 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1418 if (-x $hook) {
1419 system($hook, "refs/heads/$state->{module}");
1422 $updater->update();
1424 # foreach file specified on the command line ...
1425 foreach my $filename ( @committedfiles )
1427 $filename = filecleanup($filename);
1429 my $meta = $updater->getmeta($filename);
1430 unless (defined $meta->{revision}) {
1431 $meta->{revision} = 1;
1434 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1436 $log->debug("Checked-in $dirpart : $filename");
1438 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1439 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1441 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1442 print "Remove-entry $dirpart\n";
1443 print "$filename\n";
1444 } else {
1445 if ($meta->{revision} == 1) {
1446 print "M initial revision: 1.1\n";
1447 } else {
1448 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1450 print "Checked-in $dirpart\n";
1451 print "$filename\n";
1452 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1453 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1457 cleanupWorkTree();
1458 print "ok\n";
1461 sub req_status
1463 my ( $cmd, $data ) = @_;
1465 argsplit("status");
1467 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1468 #$log->debug("status state : " . Dumper($state));
1470 # Grab a handle to the SQLite db and do any necessary updates
1471 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1472 $updater->update();
1474 # if no files were specified, we need to work out what files we should be providing status on ...
1475 argsfromdir($updater);
1477 # foreach file specified on the command line ...
1478 foreach my $filename ( @{$state->{args}} )
1480 $filename = filecleanup($filename);
1482 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1484 my $meta = $updater->getmeta($filename);
1485 my $oldmeta = $meta;
1487 my $wrev = revparse($filename);
1489 # If the working copy is an old revision, lets get that version too for comparison.
1490 if ( defined($wrev) and $wrev != $meta->{revision} )
1492 $oldmeta = $updater->getmeta($filename, $wrev);
1495 # TODO : All possible statuses aren't yet implemented
1496 my $status;
1497 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1498 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1500 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1501 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1504 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1505 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1507 ( $state->{entries}{$filename}{unchanged}
1508 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1511 # Need checkout if it exists in the repo but doesn't have a working copy
1512 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1514 # Locally modified if working copy and repo copy have the same revision but there are local changes
1515 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1517 # Needs Merge if working copy revision is less than repo copy and there are local changes
1518 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1520 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1521 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1522 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1523 $status ||= "File had conflicts on merge" if ( 0 );
1525 $status ||= "Unknown";
1527 my ($filepart) = filenamesplit($filename);
1529 print "M ===================================================================\n";
1530 print "M File: $filepart\tStatus: $status\n";
1531 if ( defined($state->{entries}{$filename}{revision}) )
1533 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1534 } else {
1535 print "M Working revision:\tNo entry for $filename\n";
1537 if ( defined($meta->{revision}) )
1539 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1540 print "M Sticky Tag:\t\t(none)\n";
1541 print "M Sticky Date:\t\t(none)\n";
1542 print "M Sticky Options:\t\t(none)\n";
1543 } else {
1544 print "M Repository revision:\tNo revision control file\n";
1546 print "M\n";
1549 print "ok\n";
1552 sub req_diff
1554 my ( $cmd, $data ) = @_;
1556 argsplit("diff");
1558 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1559 #$log->debug("status state : " . Dumper($state));
1561 my ($revision1, $revision2);
1562 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1564 $revision1 = $state->{opt}{r}[0];
1565 $revision2 = $state->{opt}{r}[1];
1566 } else {
1567 $revision1 = $state->{opt}{r};
1570 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1571 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1573 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1575 # Grab a handle to the SQLite db and do any necessary updates
1576 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1577 $updater->update();
1579 # if no files were specified, we need to work out what files we should be providing status on ...
1580 argsfromdir($updater);
1582 # foreach file specified on the command line ...
1583 foreach my $filename ( @{$state->{args}} )
1585 $filename = filecleanup($filename);
1587 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1589 my $wrev = revparse($filename);
1591 # We need _something_ to diff against
1592 next unless ( defined ( $wrev ) );
1594 # if we have a -r switch, use it
1595 if ( defined ( $revision1 ) )
1597 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1598 $meta1 = $updater->getmeta($filename, $revision1);
1599 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1601 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1602 next;
1604 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1606 # otherwise we just use the working copy revision
1607 else
1609 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1610 $meta1 = $updater->getmeta($filename, $wrev);
1611 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1614 # if we have a second -r switch, use it too
1615 if ( defined ( $revision2 ) )
1617 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1618 $meta2 = $updater->getmeta($filename, $revision2);
1620 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1622 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1623 next;
1626 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1628 # otherwise we just use the working copy
1629 else
1631 $file2 = $state->{entries}{$filename}{modified_filename};
1634 # if we have been given -r, and we don't have a $file2 yet, lets get one
1635 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1637 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1638 $meta2 = $updater->getmeta($filename, $wrev);
1639 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1642 # We need to have retrieved something useful
1643 next unless ( defined ( $meta1 ) );
1645 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1646 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1648 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1649 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1652 # Apparently we only show diffs for locally modified files
1653 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1655 print "M Index: $filename\n";
1656 print "M ===================================================================\n";
1657 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1658 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1659 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1660 print "M diff ";
1661 foreach my $opt ( keys %{$state->{opt}} )
1663 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1665 foreach my $value ( @{$state->{opt}{$opt}} )
1667 print "-$opt $value ";
1669 } else {
1670 print "-$opt ";
1671 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1674 print "$filename\n";
1676 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1678 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1680 if ( exists $state->{opt}{u} )
1682 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1683 } else {
1684 system("diff $file1 $file2 > $filediff");
1687 while ( <$fh> )
1689 print "M $_";
1691 close $fh;
1694 print "ok\n";
1697 sub req_log
1699 my ( $cmd, $data ) = @_;
1701 argsplit("log");
1703 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1704 #$log->debug("log state : " . Dumper($state));
1706 my ( $minrev, $maxrev );
1707 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1709 my $control = $2;
1710 $minrev = $1;
1711 $maxrev = $3;
1712 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1713 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1714 $minrev++ if ( defined($minrev) and $control eq "::" );
1717 # Grab a handle to the SQLite db and do any necessary updates
1718 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1719 $updater->update();
1721 # if no files were specified, we need to work out what files we should be providing status on ...
1722 argsfromdir($updater);
1724 # foreach file specified on the command line ...
1725 foreach my $filename ( @{$state->{args}} )
1727 $filename = filecleanup($filename);
1729 my $headmeta = $updater->getmeta($filename);
1731 my $revisions = $updater->getlog($filename);
1732 my $totalrevisions = scalar(@$revisions);
1734 if ( defined ( $minrev ) )
1736 $log->debug("Removing revisions less than $minrev");
1737 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1739 pop @$revisions;
1742 if ( defined ( $maxrev ) )
1744 $log->debug("Removing revisions greater than $maxrev");
1745 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1747 shift @$revisions;
1751 next unless ( scalar(@$revisions) );
1753 print "M \n";
1754 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1755 print "M Working file: $filename\n";
1756 print "M head: 1.$headmeta->{revision}\n";
1757 print "M branch:\n";
1758 print "M locks: strict\n";
1759 print "M access list:\n";
1760 print "M symbolic names:\n";
1761 print "M keyword substitution: kv\n";
1762 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1763 print "M description:\n";
1765 foreach my $revision ( @$revisions )
1767 print "M ----------------------------\n";
1768 print "M revision 1.$revision->{revision}\n";
1769 # reformat the date for log output
1770 $revision->{modified} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1771 $revision->{author} = cvs_author($revision->{author});
1772 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1773 my $commitmessage = $updater->commitmessage($revision->{commithash});
1774 $commitmessage =~ s/^/M /mg;
1775 print $commitmessage . "\n";
1777 print "M =============================================================================\n";
1780 print "ok\n";
1783 sub req_annotate
1785 my ( $cmd, $data ) = @_;
1787 argsplit("annotate");
1789 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1790 #$log->debug("status state : " . Dumper($state));
1792 # Grab a handle to the SQLite db and do any necessary updates
1793 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1794 $updater->update();
1796 # if no files were specified, we need to work out what files we should be providing annotate on ...
1797 argsfromdir($updater);
1799 # we'll need a temporary checkout dir
1800 setupWorkTree();
1802 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1804 # foreach file specified on the command line ...
1805 foreach my $filename ( @{$state->{args}} )
1807 $filename = filecleanup($filename);
1809 my $meta = $updater->getmeta($filename);
1811 next unless ( $meta->{revision} );
1813 # get all the commits that this file was in
1814 # in dense format -- aka skip dead revisions
1815 my $revisions = $updater->gethistorydense($filename);
1816 my $lastseenin = $revisions->[0][2];
1818 # populate the temporary index based on the latest commit were we saw
1819 # the file -- but do it cheaply without checking out any files
1820 # TODO: if we got a revision from the client, use that instead
1821 # to look up the commithash in sqlite (still good to default to
1822 # the current head as we do now)
1823 system("git-read-tree", $lastseenin);
1824 unless ($? == 0)
1826 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1827 return;
1829 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1831 # do a checkout of the file
1832 system('git-checkout-index', '-f', '-u', $filename);
1833 unless ($? == 0) {
1834 print "E error running git-checkout-index -f -u $filename : $!\n";
1835 return;
1838 $log->info("Annotate $filename");
1840 # Prepare a file with the commits from the linearized
1841 # history that annotate should know about. This prevents
1842 # git-jsannotate telling us about commits we are hiding
1843 # from the client.
1845 my $a_hints = "$work->{workDir}/.annotate_hints";
1846 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1847 print "E failed to open '$a_hints' for writing: $!\n";
1848 return;
1850 for (my $i=0; $i < @$revisions; $i++)
1852 print ANNOTATEHINTS $revisions->[$i][2];
1853 if ($i+1 < @$revisions) { # have we got a parent?
1854 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1856 print ANNOTATEHINTS "\n";
1859 print ANNOTATEHINTS "\n";
1860 close ANNOTATEHINTS
1861 or (print "E failed to write $a_hints: $!\n"), return;
1863 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1864 if (!open(ANNOTATE, "-|", @cmd)) {
1865 print "E error invoking ". join(' ',@cmd) .": $!\n";
1866 return;
1868 my $metadata = {};
1869 print "E Annotations for $filename\n";
1870 print "E ***************\n";
1871 while ( <ANNOTATE> )
1873 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1875 my $commithash = $1;
1876 my $data = $2;
1877 unless ( defined ( $metadata->{$commithash} ) )
1879 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1880 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1881 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1883 printf("M 1.%-5d (%-8s %10s): %s\n",
1884 $metadata->{$commithash}{revision},
1885 $metadata->{$commithash}{author},
1886 $metadata->{$commithash}{modified},
1887 $data
1889 } else {
1890 $log->warn("Error in annotate output! LINE: $_");
1891 print "E Annotate error \n";
1892 next;
1895 close ANNOTATE;
1898 # done; get out of the tempdir
1899 cleanupWorkTree();
1901 print "ok\n";
1905 # This method takes the state->{arguments} array and produces two new arrays.
1906 # The first is $state->{args} which is everything before the '--' argument, and
1907 # the second is $state->{files} which is everything after it.
1908 sub argsplit
1910 $state->{args} = [];
1911 $state->{files} = [];
1912 $state->{opt} = {};
1914 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1916 my $type = shift;
1918 if ( defined($type) )
1920 my $opt = {};
1921 $opt = { A => 0, N => 0, P => 0, R => 0, c => 0, f => 0, l => 0, n => 0, p => 0, s => 0, r => 1, D => 1, d => 1, k => 1, j => 1, } if ( $type eq "co" );
1922 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1923 $opt = { A => 0, P => 0, C => 0, d => 0, f => 0, l => 0, R => 0, p => 0, k => 1, r => 1, D => 1, j => 1, I => 1, W => 1 } if ( $type eq "update" );
1924 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1925 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1926 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1927 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1928 $opt = { l => 0, b => 0, h => 0, R => 0, t => 0, N => 0, S => 0, r => 1, d => 1, s => 1, w => 1 } if ( $type eq "log" );
1931 while ( scalar ( @{$state->{arguments}} ) > 0 )
1933 my $arg = shift @{$state->{arguments}};
1935 next if ( $arg eq "--" );
1936 next unless ( $arg =~ /\S/ );
1938 # if the argument looks like a switch
1939 if ( $arg =~ /^-(\w)(.*)/ )
1941 # if it's a switch that takes an argument
1942 if ( $opt->{$1} )
1944 # If this switch has already been provided
1945 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1947 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1948 if ( length($2) > 0 )
1950 push @{$state->{opt}{$1}},$2;
1951 } else {
1952 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1954 } else {
1955 # if there's extra data in the arg, use that as the argument for the switch
1956 if ( length($2) > 0 )
1958 $state->{opt}{$1} = $2;
1959 } else {
1960 $state->{opt}{$1} = shift @{$state->{arguments}};
1963 } else {
1964 $state->{opt}{$1} = undef;
1967 else
1969 push @{$state->{args}}, $arg;
1973 else
1975 my $mode = 0;
1977 foreach my $value ( @{$state->{arguments}} )
1979 if ( $value eq "--" )
1981 $mode++;
1982 next;
1984 push @{$state->{args}}, $value if ( $mode == 0 );
1985 push @{$state->{files}}, $value if ( $mode == 1 );
1990 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1991 sub argsfromdir
1993 my $updater = shift;
1995 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1997 return if ( scalar ( @{$state->{args}} ) > 1 );
1999 my @gethead = @{$updater->gethead};
2001 # push added files
2002 foreach my $file (keys %{$state->{entries}}) {
2003 if ( exists $state->{entries}{$file}{revision} &&
2004 $state->{entries}{$file}{revision} == 0 )
2006 push @gethead, { name => $file, filehash => 'added' };
2010 if ( scalar(@{$state->{args}}) == 1 )
2012 my $arg = $state->{args}[0];
2013 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2015 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2017 foreach my $file ( @gethead )
2019 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2020 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2021 push @{$state->{args}}, $file->{name};
2024 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2025 } else {
2026 $log->info("Only one arg specified, populating file list automatically");
2028 $state->{args} = [];
2030 foreach my $file ( @gethead )
2032 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2033 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2034 push @{$state->{args}}, $file->{name};
2039 # This method cleans up the $state variable after a command that uses arguments has run
2040 sub statecleanup
2042 $state->{files} = [];
2043 $state->{args} = [];
2044 $state->{arguments} = [];
2045 $state->{entries} = {};
2048 sub revparse
2050 my $filename = shift;
2052 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2054 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2055 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2057 return undef;
2060 # This method takes a file hash and does a CVS "file transfer". Its
2061 # exact behaviour depends on a second, optional hash table argument:
2062 # - If $options->{targetfile}, dump the contents to that file;
2063 # - If $options->{print}, use M/MT to transmit the contents one line
2064 # at a time;
2065 # - Otherwise, transmit the size of the file, followed by the file
2066 # contents.
2067 sub transmitfile
2069 my $filehash = shift;
2070 my $options = shift;
2072 if ( defined ( $filehash ) and $filehash eq "deleted" )
2074 $log->warn("filehash is 'deleted'");
2075 return;
2078 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2080 my $type = `git-cat-file -t $filehash`;
2081 chomp $type;
2083 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2085 my $size = `git-cat-file -s $filehash`;
2086 chomp $size;
2088 $log->debug("transmitfile($filehash) size=$size, type=$type");
2090 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2092 if ( defined ( $options->{targetfile} ) )
2094 my $targetfile = $options->{targetfile};
2095 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2096 print NEWFILE $_ while ( <$fh> );
2097 close NEWFILE or die("Failed to write '$targetfile': $!");
2098 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2099 while ( <$fh> ) {
2100 if( /\n\z/ ) {
2101 print 'M ', $_;
2102 } else {
2103 print 'MT text ', $_, "\n";
2106 } else {
2107 print "$size\n";
2108 print while ( <$fh> );
2110 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2111 } else {
2112 die("Couldn't execute git-cat-file");
2116 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2117 # refers to the directory portion and the file portion of the filename
2118 # respectively
2119 sub filenamesplit
2121 my $filename = shift;
2122 my $fixforlocaldir = shift;
2124 my ( $filepart, $dirpart ) = ( $filename, "." );
2125 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2126 $dirpart .= "/";
2128 if ( $fixforlocaldir )
2130 $dirpart =~ s/^$state->{prependdir}//;
2133 return ( $filepart, $dirpart );
2136 sub filecleanup
2138 my $filename = shift;
2140 return undef unless(defined($filename));
2141 if ( $filename =~ /^\// )
2143 print "E absolute filenames '$filename' not supported by server\n";
2144 return undef;
2147 $filename =~ s/^\.\///g;
2148 $filename = $state->{prependdir} . $filename;
2149 return $filename;
2152 sub validateGitDir
2154 if( !defined($state->{CVSROOT}) )
2156 print "error 1 CVSROOT not specified\n";
2157 cleanupWorkTree();
2158 exit;
2160 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2162 print "error 1 Internally inconsistent CVSROOT\n";
2163 cleanupWorkTree();
2164 exit;
2168 # Setup working directory in a work tree with the requested version
2169 # loaded in the index.
2170 sub setupWorkTree
2172 my ($ver) = @_;
2174 validateGitDir();
2176 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2177 defined($work->{tmpDir}) )
2179 $log->warn("Bad work tree state management");
2180 print "error 1 Internal setup multiple work trees without cleanup\n";
2181 cleanupWorkTree();
2182 exit;
2185 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2187 if( !defined($work->{index}) )
2189 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2192 chdir $work->{workDir} or
2193 die "Unable to chdir to $work->{workDir}\n";
2195 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2197 $ENV{GIT_WORK_TREE} = ".";
2198 $ENV{GIT_INDEX_FILE} = $work->{index};
2199 $work->{state} = 2;
2201 if($ver)
2203 system("git","read-tree",$ver);
2204 unless ($? == 0)
2206 $log->warn("Error running git-read-tree");
2207 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2210 # else # req_annotate reads tree for each file
2213 # Ensure current directory is in some kind of working directory,
2214 # with a recent version loaded in the index.
2215 sub ensureWorkTree
2217 if( defined($work->{tmpDir}) )
2219 $log->warn("Bad work tree state management [ensureWorkTree()]");
2220 print "error 1 Internal setup multiple dirs without cleanup\n";
2221 cleanupWorkTree();
2222 exit;
2224 if( $work->{state} )
2226 return;
2229 validateGitDir();
2231 if( !defined($work->{emptyDir}) )
2233 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2235 chdir $work->{emptyDir} or
2236 die "Unable to chdir to $work->{emptyDir}\n";
2238 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2239 chomp $ver;
2240 if ($ver !~ /^[0-9a-f]{40}$/)
2242 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2243 print "error 1 cannot find the current HEAD of module";
2244 cleanupWorkTree();
2245 exit;
2248 if( !defined($work->{index}) )
2250 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2253 $ENV{GIT_WORK_TREE} = ".";
2254 $ENV{GIT_INDEX_FILE} = $work->{index};
2255 $work->{state} = 1;
2257 system("git","read-tree",$ver);
2258 unless ($? == 0)
2260 die "Error running git-read-tree $ver $!\n";
2264 # Cleanup working directory that is not needed any longer.
2265 sub cleanupWorkTree
2267 if( ! $work->{state} )
2269 return;
2272 chdir "/" or die "Unable to chdir '/'\n";
2274 if( defined($work->{workDir}) )
2276 rmtree( $work->{workDir} );
2277 undef $work->{workDir};
2279 undef $work->{state};
2282 # Setup a temporary directory (not a working tree), typically for
2283 # merging dirty state as in req_update.
2284 sub setupTmpDir
2286 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2287 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2289 return $work->{tmpDir};
2292 # Clean up a previously setupTmpDir. Restore previous work tree if
2293 # appropriate.
2294 sub cleanupTmpDir
2296 if ( !defined($work->{tmpDir}) )
2298 $log->warn("cleanup tmpdir that has not been setup");
2299 die "Cleanup tmpDir that has not been setup\n";
2301 if( defined($work->{state}) )
2303 if( $work->{state} == 1 )
2305 chdir $work->{emptyDir} or
2306 die "Unable to chdir to $work->{emptyDir}\n";
2308 elsif( $work->{state} == 2 )
2310 chdir $work->{workDir} or
2311 die "Unable to chdir to $work->{emptyDir}\n";
2313 else
2315 $log->warn("Inconsistent work dir state");
2316 die "Inconsistent work dir state\n";
2319 else
2321 chdir "/" or die "Unable to chdir '/'\n";
2325 # Given a path, this function returns a string containing the kopts
2326 # that should go into that path's Entries line. For example, a binary
2327 # file should get -kb.
2328 sub kopts_from_path
2330 my ($path, $srcType, $name) = @_;
2332 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2333 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2335 my ($val) = check_attr( "crlf", $path );
2336 if ( $val eq "set" )
2338 return "";
2340 elsif ( $val eq "unset" )
2342 return "-kb"
2344 else
2346 $log->info("Unrecognized check_attr crlf $path : $val");
2350 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2352 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2354 return "-kb";
2356 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2358 if( $srcType eq "sha1Or-k" &&
2359 !defined($name) )
2361 my ($ret)=$state->{entries}{$path}{options};
2362 if( !defined($ret) )
2364 $ret=$state->{opt}{k};
2365 if(defined($ret))
2367 $ret="-k$ret";
2369 else
2371 $ret="";
2374 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2376 print "E Bad -k option\n";
2377 $log->warn("Bad -k option: $ret");
2378 die "Error: Bad -k option: $ret\n";
2381 return $ret;
2383 else
2385 if( is_binary($srcType,$name) )
2387 $log->debug("... as binary");
2388 return "-kb";
2390 else
2392 $log->debug("... as text");
2397 # Return "" to give no special treatment to any path
2398 return "";
2401 sub check_attr
2403 my ($attr,$path) = @_;
2404 ensureWorkTree();
2405 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2407 my $val = <$fh>;
2408 close $fh;
2409 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2410 return $val;
2412 else
2414 return undef;
2418 # This should have the same heuristics as convert.c:is_binary() and related.
2419 # Note that the bare CR test is done by callers in convert.c.
2420 sub is_binary
2422 my ($srcType,$name) = @_;
2423 $log->debug("is_binary($srcType,$name)");
2425 # Minimize amount of interpreted code run in the inner per-character
2426 # loop for large files, by totalling each character value and
2427 # then analyzing the totals.
2428 my @counts;
2429 my $i;
2430 for($i=0;$i<256;$i++)
2432 $counts[$i]=0;
2435 my $fh = open_blob_or_die($srcType,$name);
2436 my $line;
2437 while( defined($line=<$fh>) )
2439 # Any '\0' and bare CR are considered binary.
2440 if( $line =~ /\0|(\r[^\n])/ )
2442 close($fh);
2443 return 1;
2446 # Count up each character in the line:
2447 my $len=length($line);
2448 for($i=0;$i<$len;$i++)
2450 $counts[ord(substr($line,$i,1))]++;
2453 close $fh;
2455 # Don't count CR and LF as either printable/nonprintable
2456 $counts[ord("\n")]=0;
2457 $counts[ord("\r")]=0;
2459 # Categorize individual character count into printable and nonprintable:
2460 my $printable=0;
2461 my $nonprintable=0;
2462 for($i=0;$i<256;$i++)
2464 if( $i < 32 &&
2465 $i != ord("\b") &&
2466 $i != ord("\t") &&
2467 $i != 033 && # ESC
2468 $i != 014 ) # FF
2470 $nonprintable+=$counts[$i];
2472 elsif( $i==127 ) # DEL
2474 $nonprintable+=$counts[$i];
2476 else
2478 $printable+=$counts[$i];
2482 return ($printable >> 7) < $nonprintable;
2485 # Returns open file handle. Possible invocations:
2486 # - open_blob_or_die("file",$filename);
2487 # - open_blob_or_die("sha1",$filehash);
2488 sub open_blob_or_die
2490 my ($srcType,$name) = @_;
2491 my ($fh);
2492 if( $srcType eq "file" )
2494 if( !open $fh,"<",$name )
2496 $log->warn("Unable to open file $name: $!");
2497 die "Unable to open file $name: $!\n";
2500 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2502 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2504 $log->warn("Need filehash");
2505 die "Need filehash\n";
2508 my $type = `git cat-file -t $name`;
2509 chomp $type;
2511 unless ( defined ( $type ) and $type eq "blob" )
2513 $log->warn("Invalid type '$type' for '$name'");
2514 die ( "Invalid type '$type' (expected 'blob')" )
2517 my $size = `git cat-file -s $name`;
2518 chomp $size;
2520 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2522 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2524 $log->warn("Unable to open sha1 $name");
2525 die "Unable to open sha1 $name\n";
2528 else
2530 $log->warn("Unknown type of blob source: $srcType");
2531 die "Unknown type of blob source: $srcType\n";
2533 return $fh;
2536 # Generate a CVS author name from Git author information, by taking the local
2537 # part of the email address and replacing characters not in the Portable
2538 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2539 # Login names are Unix login names, which should be restricted to this
2540 # character set.
2541 sub cvs_author
2543 my $author_line = shift;
2544 (my $author) = $author_line =~ /<([^@>]*)/;
2546 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2547 $author =~ s/^-/_/;
2549 $author;
2552 package GITCVS::log;
2554 ####
2555 #### Copyright The Open University UK - 2006.
2556 ####
2557 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2558 #### Martin Langhoff <martin@catalyst.net.nz>
2559 ####
2560 ####
2562 use strict;
2563 use warnings;
2565 =head1 NAME
2567 GITCVS::log
2569 =head1 DESCRIPTION
2571 This module provides very crude logging with a similar interface to
2572 Log::Log4perl
2574 =head1 METHODS
2576 =cut
2578 =head2 new
2580 Creates a new log object, optionally you can specify a filename here to
2581 indicate the file to log to. If no log file is specified, you can specify one
2582 later with method setfile, or indicate you no longer want logging with method
2583 nofile.
2585 Until one of these methods is called, all log calls will buffer messages ready
2586 to write out.
2588 =cut
2589 sub new
2591 my $class = shift;
2592 my $filename = shift;
2594 my $self = {};
2596 bless $self, $class;
2598 if ( defined ( $filename ) )
2600 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2603 return $self;
2606 =head2 setfile
2608 This methods takes a filename, and attempts to open that file as the log file.
2609 If successful, all buffered data is written out to the file, and any further
2610 logging is written directly to the file.
2612 =cut
2613 sub setfile
2615 my $self = shift;
2616 my $filename = shift;
2618 if ( defined ( $filename ) )
2620 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2623 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2625 while ( my $line = shift @{$self->{buffer}} )
2627 print {$self->{fh}} $line;
2631 =head2 nofile
2633 This method indicates no logging is going to be used. It flushes any entries in
2634 the internal buffer, and sets a flag to ensure no further data is put there.
2636 =cut
2637 sub nofile
2639 my $self = shift;
2641 $self->{nolog} = 1;
2643 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2645 $self->{buffer} = [];
2648 =head2 _logopen
2650 Internal method. Returns true if the log file is open, false otherwise.
2652 =cut
2653 sub _logopen
2655 my $self = shift;
2657 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2658 return 0;
2661 =head2 debug info warn fatal
2663 These four methods are wrappers to _log. They provide the actual interface for
2664 logging data.
2666 =cut
2667 sub debug { my $self = shift; $self->_log("debug", @_); }
2668 sub info { my $self = shift; $self->_log("info" , @_); }
2669 sub warn { my $self = shift; $self->_log("warn" , @_); }
2670 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2672 =head2 _log
2674 This is an internal method called by the logging functions. It generates a
2675 timestamp and pushes the logged line either to file, or internal buffer.
2677 =cut
2678 sub _log
2680 my $self = shift;
2681 my $level = shift;
2683 return if ( $self->{nolog} );
2685 my @time = localtime;
2686 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2687 $time[5] + 1900,
2688 $time[4] + 1,
2689 $time[3],
2690 $time[2],
2691 $time[1],
2692 $time[0],
2693 uc $level,
2696 if ( $self->_logopen )
2698 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2699 } else {
2700 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2704 =head2 DESTROY
2706 This method simply closes the file handle if one is open
2708 =cut
2709 sub DESTROY
2711 my $self = shift;
2713 if ( $self->_logopen )
2715 close $self->{fh};
2719 package GITCVS::updater;
2721 ####
2722 #### Copyright The Open University UK - 2006.
2723 ####
2724 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2725 #### Martin Langhoff <martin@catalyst.net.nz>
2726 ####
2727 ####
2729 use strict;
2730 use warnings;
2731 use DBI;
2733 =head1 METHODS
2735 =cut
2737 =head2 new
2739 =cut
2740 sub new
2742 my $class = shift;
2743 my $config = shift;
2744 my $module = shift;
2745 my $log = shift;
2747 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2748 die "Need to specify a module" unless ( defined($module) );
2750 $class = ref($class) || $class;
2752 my $self = {};
2754 bless $self, $class;
2756 $self->{valid_tables} = {'revision' => 1,
2757 'revision_ix1' => 1,
2758 'revision_ix2' => 1,
2759 'head' => 1,
2760 'head_ix1' => 1,
2761 'properties' => 1,
2762 'commitmsgs' => 1};
2764 $self->{module} = $module;
2765 $self->{git_path} = $config . "/";
2767 $self->{log} = $log;
2769 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2771 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2772 $cfg->{gitcvs}{dbdriver} || "SQLite";
2773 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2774 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2775 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2776 $cfg->{gitcvs}{dbuser} || "";
2777 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2778 $cfg->{gitcvs}{dbpass} || "";
2779 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2780 $cfg->{gitcvs}{dbtablenameprefix} || "";
2781 my %mapping = ( m => $module,
2782 a => $state->{method},
2783 u => getlogin || getpwuid($<) || $<,
2784 G => $self->{git_path},
2785 g => mangle_dirname($self->{git_path}),
2787 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2788 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2789 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2790 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2792 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2793 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2794 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2795 $self->{dbuser},
2796 $self->{dbpass});
2797 die "Error connecting to database\n" unless defined $self->{dbh};
2799 $self->{tables} = {};
2800 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2802 $self->{tables}{$table} = 1;
2805 # Construct the revision table if required
2806 unless ( $self->{tables}{$self->tablename("revision")} )
2808 my $tablename = $self->tablename("revision");
2809 my $ix1name = $self->tablename("revision_ix1");
2810 my $ix2name = $self->tablename("revision_ix2");
2811 $self->{dbh}->do("
2812 CREATE TABLE $tablename (
2813 name TEXT NOT NULL,
2814 revision INTEGER NOT NULL,
2815 filehash TEXT NOT NULL,
2816 commithash TEXT NOT NULL,
2817 author TEXT NOT NULL,
2818 modified TEXT NOT NULL,
2819 mode TEXT NOT NULL
2822 $self->{dbh}->do("
2823 CREATE INDEX $ix1name
2824 ON $tablename (name,revision)
2826 $self->{dbh}->do("
2827 CREATE INDEX $ix2name
2828 ON $tablename (name,commithash)
2832 # Construct the head table if required
2833 unless ( $self->{tables}{$self->tablename("head")} )
2835 my $tablename = $self->tablename("head");
2836 my $ix1name = $self->tablename("head_ix1");
2837 $self->{dbh}->do("
2838 CREATE TABLE $tablename (
2839 name TEXT NOT NULL,
2840 revision INTEGER NOT NULL,
2841 filehash TEXT NOT NULL,
2842 commithash TEXT NOT NULL,
2843 author TEXT NOT NULL,
2844 modified TEXT NOT NULL,
2845 mode TEXT NOT NULL
2848 $self->{dbh}->do("
2849 CREATE INDEX $ix1name
2850 ON $tablename (name)
2854 # Construct the properties table if required
2855 unless ( $self->{tables}{$self->tablename("properties")} )
2857 my $tablename = $self->tablename("properties");
2858 $self->{dbh}->do("
2859 CREATE TABLE $tablename (
2860 key TEXT NOT NULL PRIMARY KEY,
2861 value TEXT
2866 # Construct the commitmsgs table if required
2867 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2869 my $tablename = $self->tablename("commitmsgs");
2870 $self->{dbh}->do("
2871 CREATE TABLE $tablename (
2872 key TEXT NOT NULL PRIMARY KEY,
2873 value TEXT
2878 return $self;
2881 =head2 tablename
2883 =cut
2884 sub tablename
2886 my $self = shift;
2887 my $name = shift;
2889 if (exists $self->{valid_tables}{$name}) {
2890 return $self->{dbtablenameprefix} . $name;
2891 } else {
2892 return undef;
2896 =head2 update
2898 =cut
2899 sub update
2901 my $self = shift;
2903 # first lets get the commit list
2904 $ENV{GIT_DIR} = $self->{git_path};
2906 my $commitsha1 = `git rev-parse $self->{module}`;
2907 chomp $commitsha1;
2909 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2910 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2912 die("Invalid module '$self->{module}'");
2916 my $git_log;
2917 my $lastcommit = $self->_get_prop("last_commit");
2919 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2920 return 1;
2923 # Start exclusive lock here...
2924 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2926 # TODO: log processing is memory bound
2927 # if we can parse into a 2nd file that is in reverse order
2928 # we can probably do something really efficient
2929 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2931 if (defined $lastcommit) {
2932 push @git_log_params, "$lastcommit..$self->{module}";
2933 } else {
2934 push @git_log_params, $self->{module};
2936 # git-rev-list is the backend / plumbing version of git-log
2937 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2939 my @commits;
2941 my %commit = ();
2943 while ( <GITLOG> )
2945 chomp;
2946 if (m/^commit\s+(.*)$/) {
2947 # on ^commit lines put the just seen commit in the stack
2948 # and prime things for the next one
2949 if (keys %commit) {
2950 my %copy = %commit;
2951 unshift @commits, \%copy;
2952 %commit = ();
2954 my @parents = split(m/\s+/, $1);
2955 $commit{hash} = shift @parents;
2956 $commit{parents} = \@parents;
2957 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2958 # on rfc822-like lines seen before we see any message,
2959 # lowercase the entry and put it in the hash as key-value
2960 $commit{lc($1)} = $2;
2961 } else {
2962 # message lines - skip initial empty line
2963 # and trim whitespace
2964 if (!exists($commit{message}) && m/^\s*$/) {
2965 # define it to mark the end of headers
2966 $commit{message} = '';
2967 next;
2969 s/^\s+//; s/\s+$//; # trim ws
2970 $commit{message} .= $_ . "\n";
2973 close GITLOG;
2975 unshift @commits, \%commit if ( keys %commit );
2977 # Now all the commits are in the @commits bucket
2978 # ordered by time DESC. for each commit that needs processing,
2979 # determine whether it's following the last head we've seen or if
2980 # it's on its own branch, grab a file list, and add whatever's changed
2981 # NOTE: $lastcommit refers to the last commit from previous run
2982 # $lastpicked is the last commit we picked in this run
2983 my $lastpicked;
2984 my $head = {};
2985 if (defined $lastcommit) {
2986 $lastpicked = $lastcommit;
2989 my $committotal = scalar(@commits);
2990 my $commitcount = 0;
2992 # Load the head table into $head (for cached lookups during the update process)
2993 foreach my $file ( @{$self->gethead()} )
2995 $head->{$file->{name}} = $file;
2998 foreach my $commit ( @commits )
3000 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3001 if (defined $lastpicked)
3003 if (!in_array($lastpicked, @{$commit->{parents}}))
3005 # skip, we'll see this delta
3006 # as part of a merge later
3007 # warn "skipping off-track $commit->{hash}\n";
3008 next;
3009 } elsif (@{$commit->{parents}} > 1) {
3010 # it is a merge commit, for each parent that is
3011 # not $lastpicked, see if we can get a log
3012 # from the merge-base to that parent to put it
3013 # in the message as a merge summary.
3014 my @parents = @{$commit->{parents}};
3015 foreach my $parent (@parents) {
3016 # git-merge-base can potentially (but rarely) throw
3017 # several candidate merge bases. let's assume
3018 # that the first one is the best one.
3019 if ($parent eq $lastpicked) {
3020 next;
3022 my $base = eval {
3023 safe_pipe_capture('git-merge-base',
3024 $lastpicked, $parent);
3026 # The two branches may not be related at all,
3027 # in which case merge base simply fails to find
3028 # any, but that's Ok.
3029 next if ($@);
3031 chomp $base;
3032 if ($base) {
3033 my @merged;
3034 # print "want to log between $base $parent \n";
3035 open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3036 or die "Cannot call git-log: $!";
3037 my $mergedhash;
3038 while (<GITLOG>) {
3039 chomp;
3040 if (!defined $mergedhash) {
3041 if (m/^commit\s+(.+)$/) {
3042 $mergedhash = $1;
3043 } else {
3044 next;
3046 } else {
3047 # grab the first line that looks non-rfc822
3048 # aka has content after leading space
3049 if (m/^\s+(\S.*)$/) {
3050 my $title = $1;
3051 $title = substr($title,0,100); # truncate
3052 unshift @merged, "$mergedhash $title";
3053 undef $mergedhash;
3057 close GITLOG;
3058 if (@merged) {
3059 $commit->{mergemsg} = $commit->{message};
3060 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3061 foreach my $summary (@merged) {
3062 $commit->{mergemsg} .= "\t$summary\n";
3064 $commit->{mergemsg} .= "\n\n";
3065 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3072 # convert the date to CVS-happy format
3073 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3075 if ( defined ( $lastpicked ) )
3077 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3078 local ($/) = "\0";
3079 while ( <FILELIST> )
3081 chomp;
3082 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3084 die("Couldn't process git-diff-tree line : $_");
3086 my ($mode, $hash, $change) = ($1, $2, $3);
3087 my $name = <FILELIST>;
3088 chomp($name);
3090 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3092 my $git_perms = "";
3093 $git_perms .= "r" if ( $mode & 4 );
3094 $git_perms .= "w" if ( $mode & 2 );
3095 $git_perms .= "x" if ( $mode & 1 );
3096 $git_perms = "rw" if ( $git_perms eq "" );
3098 if ( $change eq "D" )
3100 #$log->debug("DELETE $name");
3101 $head->{$name} = {
3102 name => $name,
3103 revision => $head->{$name}{revision} + 1,
3104 filehash => "deleted",
3105 commithash => $commit->{hash},
3106 modified => $commit->{date},
3107 author => $commit->{author},
3108 mode => $git_perms,
3110 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3112 elsif ( $change eq "M" || $change eq "T" )
3114 #$log->debug("MODIFIED $name");
3115 $head->{$name} = {
3116 name => $name,
3117 revision => $head->{$name}{revision} + 1,
3118 filehash => $hash,
3119 commithash => $commit->{hash},
3120 modified => $commit->{date},
3121 author => $commit->{author},
3122 mode => $git_perms,
3124 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3126 elsif ( $change eq "A" )
3128 #$log->debug("ADDED $name");
3129 $head->{$name} = {
3130 name => $name,
3131 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3132 filehash => $hash,
3133 commithash => $commit->{hash},
3134 modified => $commit->{date},
3135 author => $commit->{author},
3136 mode => $git_perms,
3138 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3140 else
3142 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3143 die;
3146 close FILELIST;
3147 } else {
3148 # this is used to detect files removed from the repo
3149 my $seen_files = {};
3151 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3152 local $/ = "\0";
3153 while ( <FILELIST> )
3155 chomp;
3156 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3158 die("Couldn't process git-ls-tree line : $_");
3161 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3163 $seen_files->{$git_filename} = 1;
3165 my ( $oldhash, $oldrevision, $oldmode ) = (
3166 $head->{$git_filename}{filehash},
3167 $head->{$git_filename}{revision},
3168 $head->{$git_filename}{mode}
3171 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3173 $git_perms = "";
3174 $git_perms .= "r" if ( $1 & 4 );
3175 $git_perms .= "w" if ( $1 & 2 );
3176 $git_perms .= "x" if ( $1 & 1 );
3177 } else {
3178 $git_perms = "rw";
3181 # unless the file exists with the same hash, we need to update it ...
3182 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3184 my $newrevision = ( $oldrevision or 0 ) + 1;
3186 $head->{$git_filename} = {
3187 name => $git_filename,
3188 revision => $newrevision,
3189 filehash => $git_hash,
3190 commithash => $commit->{hash},
3191 modified => $commit->{date},
3192 author => $commit->{author},
3193 mode => $git_perms,
3197 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3200 close FILELIST;
3202 # Detect deleted files
3203 foreach my $file ( keys %$head )
3205 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3207 $head->{$file}{revision}++;
3208 $head->{$file}{filehash} = "deleted";
3209 $head->{$file}{commithash} = $commit->{hash};
3210 $head->{$file}{modified} = $commit->{date};
3211 $head->{$file}{author} = $commit->{author};
3213 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3216 # END : "Detect deleted files"
3220 if (exists $commit->{mergemsg})
3222 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3225 $lastpicked = $commit->{hash};
3227 $self->_set_prop("last_commit", $commit->{hash});
3230 $self->delete_head();
3231 foreach my $file ( keys %$head )
3233 $self->insert_head(
3234 $file,
3235 $head->{$file}{revision},
3236 $head->{$file}{filehash},
3237 $head->{$file}{commithash},
3238 $head->{$file}{modified},
3239 $head->{$file}{author},
3240 $head->{$file}{mode},
3243 # invalidate the gethead cache
3244 $self->{gethead_cache} = undef;
3247 # Ending exclusive lock here
3248 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3251 sub insert_rev
3253 my $self = shift;
3254 my $name = shift;
3255 my $revision = shift;
3256 my $filehash = shift;
3257 my $commithash = shift;
3258 my $modified = shift;
3259 my $author = shift;
3260 my $mode = shift;
3261 my $tablename = $self->tablename("revision");
3263 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3264 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3267 sub insert_mergelog
3269 my $self = shift;
3270 my $key = shift;
3271 my $value = shift;
3272 my $tablename = $self->tablename("commitmsgs");
3274 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3275 $insert_mergelog->execute($key, $value);
3278 sub delete_head
3280 my $self = shift;
3281 my $tablename = $self->tablename("head");
3283 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3284 $delete_head->execute();
3287 sub insert_head
3289 my $self = shift;
3290 my $name = shift;
3291 my $revision = shift;
3292 my $filehash = shift;
3293 my $commithash = shift;
3294 my $modified = shift;
3295 my $author = shift;
3296 my $mode = shift;
3297 my $tablename = $self->tablename("head");
3299 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3300 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3303 sub _headrev
3305 my $self = shift;
3306 my $filename = shift;
3307 my $tablename = $self->tablename("head");
3309 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3310 $db_query->execute($filename);
3311 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3313 return ( $hash, $revision, $mode );
3316 sub _get_prop
3318 my $self = shift;
3319 my $key = shift;
3320 my $tablename = $self->tablename("properties");
3322 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3323 $db_query->execute($key);
3324 my ( $value ) = $db_query->fetchrow_array;
3326 return $value;
3329 sub _set_prop
3331 my $self = shift;
3332 my $key = shift;
3333 my $value = shift;
3334 my $tablename = $self->tablename("properties");
3336 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3337 $db_query->execute($value, $key);
3339 unless ( $db_query->rows )
3341 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3342 $db_query->execute($key, $value);
3345 return $value;
3348 =head2 gethead
3350 =cut
3352 sub gethead
3354 my $self = shift;
3355 my $tablename = $self->tablename("head");
3357 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3359 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3360 $db_query->execute();
3362 my $tree = [];
3363 while ( my $file = $db_query->fetchrow_hashref )
3365 push @$tree, $file;
3368 $self->{gethead_cache} = $tree;
3370 return $tree;
3373 =head2 getlog
3375 =cut
3377 sub getlog
3379 my $self = shift;
3380 my $filename = shift;
3381 my $tablename = $self->tablename("revision");
3383 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3384 $db_query->execute($filename);
3386 my $tree = [];
3387 while ( my $file = $db_query->fetchrow_hashref )
3389 push @$tree, $file;
3392 return $tree;
3395 =head2 getmeta
3397 This function takes a filename (with path) argument and returns a hashref of
3398 metadata for that file.
3400 =cut
3402 sub getmeta
3404 my $self = shift;
3405 my $filename = shift;
3406 my $revision = shift;
3407 my $tablename_rev = $self->tablename("revision");
3408 my $tablename_head = $self->tablename("head");
3410 my $db_query;
3411 if ( defined($revision) and $revision =~ /^\d+$/ )
3413 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3414 $db_query->execute($filename, $revision);
3416 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3418 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3419 $db_query->execute($filename, $revision);
3420 } else {
3421 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3422 $db_query->execute($filename);
3425 return $db_query->fetchrow_hashref;
3428 =head2 commitmessage
3430 this function takes a commithash and returns the commit message for that commit
3432 =cut
3433 sub commitmessage
3435 my $self = shift;
3436 my $commithash = shift;
3437 my $tablename = $self->tablename("commitmsgs");
3439 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3441 my $db_query;
3442 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3443 $db_query->execute($commithash);
3445 my ( $message ) = $db_query->fetchrow_array;
3447 if ( defined ( $message ) )
3449 $message .= " " if ( $message =~ /\n$/ );
3450 return $message;
3453 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3454 shift @lines while ( $lines[0] =~ /\S/ );
3455 $message = join("",@lines);
3456 $message .= " " if ( $message =~ /\n$/ );
3457 return $message;
3460 =head2 gethistory
3462 This function takes a filename (with path) argument and returns an arrayofarrays
3463 containing revision,filehash,commithash ordered by revision descending
3465 =cut
3466 sub gethistory
3468 my $self = shift;
3469 my $filename = shift;
3470 my $tablename = $self->tablename("revision");
3472 my $db_query;
3473 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3474 $db_query->execute($filename);
3476 return $db_query->fetchall_arrayref;
3479 =head2 gethistorydense
3481 This function takes a filename (with path) argument and returns an arrayofarrays
3482 containing revision,filehash,commithash ordered by revision descending.
3484 This version of gethistory skips deleted entries -- so it is useful for annotate.
3485 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3486 and other git tools that depend on it.
3488 =cut
3489 sub gethistorydense
3491 my $self = shift;
3492 my $filename = shift;
3493 my $tablename = $self->tablename("revision");
3495 my $db_query;
3496 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3497 $db_query->execute($filename);
3499 return $db_query->fetchall_arrayref;
3502 =head2 in_array()
3504 from Array::PAT - mimics the in_array() function
3505 found in PHP. Yuck but works for small arrays.
3507 =cut
3508 sub in_array
3510 my ($check, @array) = @_;
3511 my $retval = 0;
3512 foreach my $test (@array){
3513 if($check eq $test){
3514 $retval = 1;
3517 return $retval;
3520 =head2 safe_pipe_capture
3522 an alternative to `command` that allows input to be passed as an array
3523 to work around shell problems with weird characters in arguments
3525 =cut
3526 sub safe_pipe_capture {
3528 my @output;
3530 if (my $pid = open my $child, '-|') {
3531 @output = (<$child>);
3532 close $child or die join(' ',@_).": $! $?";
3533 } else {
3534 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3536 return wantarray ? @output : join('',@output);
3539 =head2 mangle_dirname
3541 create a string from a directory name that is suitable to use as
3542 part of a filename, mainly by converting all chars except \w.- to _
3544 =cut
3545 sub mangle_dirname {
3546 my $dirname = shift;
3547 return unless defined $dirname;
3549 $dirname =~ s/[^\w.-]/_/g;
3551 return $dirname;
3554 =head2 mangle_tablename
3556 create a string from a that is suitable to use as part of an SQL table
3557 name, mainly by converting all chars except \w to _
3559 =cut
3560 sub mangle_tablename {
3561 my $tablename = shift;
3562 return unless defined $tablename;
3564 $tablename =~ s/[^\w_]/_/g;
3566 return $tablename;