Merge branch 'en/and-cascade-tests'
[git/kirr.git] / git-cvsserver.perl
blob1b8bff2cac163a6588df397168f57214c30b4784
1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@laptop.org>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use 5.008;
19 use strict;
20 use warnings;
21 use bytes;
23 use Fcntl;
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
26 use File::Basename;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
32 my $cfg;
34 my $DATE_LIST = {
35 Jan => "01",
36 Feb => "02",
37 Mar => "03",
38 Apr => "04",
39 May => "05",
40 Jun => "06",
41 Jul => "07",
42 Aug => "08",
43 Sep => "09",
44 Oct => "10",
45 Nov => "11",
46 Dec => "12",
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50 $| = 1;
52 #### Definition and mappings of functions ####
54 my $methods = {
55 'Root' => \&req_Root,
56 'Valid-responses' => \&req_Validresponses,
57 'valid-requests' => \&req_validrequests,
58 'Directory' => \&req_Directory,
59 'Entry' => \&req_Entry,
60 'Modified' => \&req_Modified,
61 'Unchanged' => \&req_Unchanged,
62 'Questionable' => \&req_Questionable,
63 'Argument' => \&req_Argument,
64 'Argumentx' => \&req_Argument,
65 'expand-modules' => \&req_expandmodules,
66 'add' => \&req_add,
67 'remove' => \&req_remove,
68 'co' => \&req_co,
69 'update' => \&req_update,
70 'ci' => \&req_ci,
71 'diff' => \&req_diff,
72 'log' => \&req_log,
73 'rlog' => \&req_log,
74 'tag' => \&req_CATCHALL,
75 'status' => \&req_status,
76 'admin' => \&req_CATCHALL,
77 'history' => \&req_CATCHALL,
78 'watchers' => \&req_EMPTY,
79 'editors' => \&req_EMPTY,
80 'noop' => \&req_EMPTY,
81 'annotate' => \&req_annotate,
82 'Global_option' => \&req_Globaloption,
83 #'annotate' => \&req_CATCHALL,
86 ##############################################
89 # $state holds all the bits of information the clients sends us that could
90 # potentially be useful when it comes to actually _doing_ something.
91 my $state = { prependdir => '' };
93 # Work is for managing temporary working directory
94 my $work =
96 state => undef, # undef, 1 (empty), 2 (with stuff)
97 workDir => undef,
98 index => undef,
99 emptyDir => undef,
100 tmpDir => undef
103 $log->info("--------------- STARTING -----------------");
105 my $usage =
106 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
107 " --base-path <path> : Prepend to requested CVSROOT\n".
108 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
109 " --strict-paths : Don't allow recursing into subdirectories\n".
110 " --export-all : Don't check for gitcvs.enabled in config\n".
111 " --version, -V : Print version information and exit\n".
112 " --help, -h, -H : Print usage information and exit\n".
113 "\n".
114 "<directory> ... is a list of allowed directories. If no directories\n".
115 "are given, all are allowed. This is an additional restriction, gitcvs\n".
116 "access still needs to be enabled by the gitcvs.enabled config option.\n".
117 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
119 my @opts = ( 'help|h|H', 'version|V',
120 'base-path=s', 'strict-paths', 'export-all' );
121 GetOptions( $state, @opts )
122 or die $usage;
124 if ($state->{version}) {
125 print "git-cvsserver version $VERSION\n";
126 exit;
128 if ($state->{help}) {
129 print $usage;
130 exit;
133 my $TEMP_DIR = tempdir( CLEANUP => 1 );
134 $log->debug("Temporary directory is '$TEMP_DIR'");
136 $state->{method} = 'ext';
137 if (@ARGV) {
138 if ($ARGV[0] eq 'pserver') {
139 $state->{method} = 'pserver';
140 shift @ARGV;
141 } elsif ($ARGV[0] eq 'server') {
142 shift @ARGV;
146 # everything else is a directory
147 $state->{allowed_roots} = [ @ARGV ];
149 # don't export the whole system unless the users requests it
150 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
151 die "--export-all can only be used together with an explicit whitelist\n";
154 # Environment handling for running under git-shell
155 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
156 if ($state->{'base-path'}) {
157 die "Cannot specify base path both ways.\n";
159 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
160 $state->{'base-path'} = $base_path;
161 $log->debug("Picked up base path '$base_path' from environment.\n");
163 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
164 if (@{$state->{allowed_roots}}) {
165 die "Cannot specify roots both ways: @ARGV\n";
167 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
168 $state->{allowed_roots} = [ $allowed_root ];
169 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
172 # if we are called with a pserver argument,
173 # deal with the authentication cat before entering the
174 # main loop
175 if ($state->{method} eq 'pserver') {
176 my $line = <STDIN>; chomp $line;
177 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
178 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
180 my $request = $1;
181 $line = <STDIN>; chomp $line;
182 unless (req_Root('root', $line)) { # reuse Root
183 print "E Invalid root $line \n";
184 exit 1;
186 $line = <STDIN>; chomp $line;
187 my $user = $line;
188 $line = <STDIN>; chomp $line;
189 my $password = $line;
191 if ($user eq 'anonymous') {
192 # "A" will be 1 byte, use length instead in case the
193 # encryption method ever changes (yeah, right!)
194 if (length($password) > 1 ) {
195 print "E Don't supply a password for the `anonymous' user\n";
196 print "I HATE YOU\n";
197 exit 1;
200 # Fall through to LOVE
201 } else {
202 # Trying to authenticate a user
203 if (not exists $cfg->{gitcvs}->{authdb}) {
204 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
205 print "I HATE YOU\n";
206 exit 1;
209 my $authdb = $cfg->{gitcvs}->{authdb};
211 unless (-e $authdb) {
212 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
213 print "I HATE YOU\n";
214 exit 1;
217 my $auth_ok;
218 open my $passwd, "<", $authdb or die $!;
219 while (<$passwd>) {
220 if (m{^\Q$user\E:(.*)}) {
221 if (crypt($user, descramble($password)) eq $1) {
222 $auth_ok = 1;
226 close $passwd;
228 unless ($auth_ok) {
229 print "I HATE YOU\n";
230 exit 1;
233 # Fall through to LOVE
236 # For checking whether the user is anonymous on commit
237 $state->{user} = $user;
239 $line = <STDIN>; chomp $line;
240 unless ($line eq "END $request REQUEST") {
241 die "E Do not understand $line -- expecting END $request REQUEST\n";
243 print "I LOVE YOU\n";
244 exit if $request eq 'VERIFICATION'; # cvs login
245 # and now back to our regular programme...
248 # Keep going until the client closes the connection
249 while (<STDIN>)
251 chomp;
253 # Check to see if we've seen this method, and call appropriate function.
254 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
256 # use the $methods hash to call the appropriate sub for this command
257 #$log->info("Method : $1");
258 &{$methods->{$1}}($1,$2);
259 } else {
260 # log fatal because we don't understand this function. If this happens
261 # we're fairly screwed because we don't know if the client is expecting
262 # a response. If it is, the client will hang, we'll hang, and the whole
263 # thing will be custard.
264 $log->fatal("Don't understand command $_\n");
265 die("Unknown command $_");
269 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
270 $log->info("--------------- FINISH -----------------");
272 chdir '/';
273 exit 0;
275 # Magic catchall method.
276 # This is the method that will handle all commands we haven't yet
277 # implemented. It simply sends a warning to the log file indicating a
278 # command that hasn't been implemented has been invoked.
279 sub req_CATCHALL
281 my ( $cmd, $data ) = @_;
282 $log->warn("Unhandled command : req_$cmd : $data");
285 # This method invariably succeeds with an empty response.
286 sub req_EMPTY
288 print "ok\n";
291 # Root pathname \n
292 # Response expected: no. Tell the server which CVSROOT to use. Note that
293 # pathname is a local directory and not a fully qualified CVSROOT variable.
294 # pathname must already exist; if creating a new root, use the init
295 # request, not Root. pathname does not include the hostname of the server,
296 # how to access the server, etc.; by the time the CVS protocol is in use,
297 # connection, authentication, etc., are already taken care of. The Root
298 # request must be sent only once, and it must be sent before any requests
299 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
300 sub req_Root
302 my ( $cmd, $data ) = @_;
303 $log->debug("req_Root : $data");
305 unless ($data =~ m#^/#) {
306 print "error 1 Root must be an absolute pathname\n";
307 return 0;
310 my $cvsroot = $state->{'base-path'} || '';
311 $cvsroot =~ s#/+$##;
312 $cvsroot .= $data;
314 if ($state->{CVSROOT}
315 && ($state->{CVSROOT} ne $cvsroot)) {
316 print "error 1 Conflicting roots specified\n";
317 return 0;
320 $state->{CVSROOT} = $cvsroot;
322 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
324 if (@{$state->{allowed_roots}}) {
325 my $allowed = 0;
326 foreach my $dir (@{$state->{allowed_roots}}) {
327 next unless $dir =~ m#^/#;
328 $dir =~ s#/+$##;
329 if ($state->{'strict-paths'}) {
330 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
331 $allowed = 1;
332 last;
334 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
335 $allowed = 1;
336 last;
340 unless ($allowed) {
341 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
342 print "E \n";
343 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
344 return 0;
348 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
349 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
350 print "E \n";
351 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
352 return 0;
355 my @gitvars = `git config -l`;
356 if ($?) {
357 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
358 print "E \n";
359 print "error 1 - problem executing git-config\n";
360 return 0;
362 foreach my $line ( @gitvars )
364 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
365 unless ($2) {
366 $cfg->{$1}{$3} = $4;
367 } else {
368 $cfg->{$1}{$2}{$3} = $4;
372 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
373 || $cfg->{gitcvs}{enabled});
374 unless ($state->{'export-all'} ||
375 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
376 print "E GITCVS emulation needs to be enabled on this repo\n";
377 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
378 print "E \n";
379 print "error 1 GITCVS emulation disabled\n";
380 return 0;
383 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
384 if ( $logfile )
386 $log->setfile($logfile);
387 } else {
388 $log->nofile();
391 return 1;
394 # Global_option option \n
395 # Response expected: no. Transmit one of the global options `-q', `-Q',
396 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
397 # variations (such as combining of options) are allowed. For graceful
398 # handling of valid-requests, it is probably better to make new global
399 # options separate requests, rather than trying to add them to this
400 # request.
401 sub req_Globaloption
403 my ( $cmd, $data ) = @_;
404 $log->debug("req_Globaloption : $data");
405 $state->{globaloptions}{$data} = 1;
408 # Valid-responses request-list \n
409 # Response expected: no. Tell the server what responses the client will
410 # accept. request-list is a space separated list of tokens.
411 sub req_Validresponses
413 my ( $cmd, $data ) = @_;
414 $log->debug("req_Validresponses : $data");
416 # TODO : re-enable this, currently it's not particularly useful
417 #$state->{validresponses} = [ split /\s+/, $data ];
420 # valid-requests \n
421 # Response expected: yes. Ask the server to send back a Valid-requests
422 # response.
423 sub req_validrequests
425 my ( $cmd, $data ) = @_;
427 $log->debug("req_validrequests");
429 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
430 $log->debug("SEND : ok");
432 print "Valid-requests " . join(" ",keys %$methods) . "\n";
433 print "ok\n";
436 # Directory local-directory \n
437 # Additional data: repository \n. Response expected: no. Tell the server
438 # what directory to use. The repository should be a directory name from a
439 # previous server response. Note that this both gives a default for Entry
440 # and Modified and also for ci and the other commands; normal usage is to
441 # send Directory for each directory in which there will be an Entry or
442 # Modified, and then a final Directory for the original directory, then the
443 # command. The local-directory is relative to the top level at which the
444 # command is occurring (i.e. the last Directory which is sent before the
445 # command); to indicate that top level, `.' should be sent for
446 # local-directory.
447 sub req_Directory
449 my ( $cmd, $data ) = @_;
451 my $repository = <STDIN>;
452 chomp $repository;
455 $state->{localdir} = $data;
456 $state->{repository} = $repository;
457 $state->{path} = $repository;
458 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
459 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
460 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
462 $state->{directory} = $state->{localdir};
463 $state->{directory} = "" if ( $state->{directory} eq "." );
464 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
466 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
468 $log->info("Setting prepend to '$state->{path}'");
469 $state->{prependdir} = $state->{path};
470 foreach my $entry ( keys %{$state->{entries}} )
472 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
473 delete $state->{entries}{$entry};
477 if ( defined ( $state->{prependdir} ) )
479 $log->debug("Prepending '$state->{prependdir}' to state|directory");
480 $state->{directory} = $state->{prependdir} . $state->{directory}
482 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
485 # Entry entry-line \n
486 # Response expected: no. Tell the server what version of a file is on the
487 # local machine. The name in entry-line is a name relative to the directory
488 # most recently specified with Directory. If the user is operating on only
489 # some files in a directory, Entry requests for only those files need be
490 # included. If an Entry request is sent without Modified, Is-modified, or
491 # Unchanged, it means the file is lost (does not exist in the working
492 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
493 # are sent for the same file, Entry must be sent first. For a given file,
494 # one can send Modified, Is-modified, or Unchanged, but not more than one
495 # of these three.
496 sub req_Entry
498 my ( $cmd, $data ) = @_;
500 #$log->debug("req_Entry : $data");
502 my @data = split(/\//, $data);
504 $state->{entries}{$state->{directory}.$data[1]} = {
505 revision => $data[2],
506 conflict => $data[3],
507 options => $data[4],
508 tag_or_date => $data[5],
511 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
514 # Questionable filename \n
515 # Response expected: no. Additional data: no. Tell the server to check
516 # whether filename should be ignored, and if not, next time the server
517 # sends responses, send (in a M response) `?' followed by the directory and
518 # filename. filename must not contain `/'; it needs to be a file in the
519 # directory named by the most recent Directory request.
520 sub req_Questionable
522 my ( $cmd, $data ) = @_;
524 $log->debug("req_Questionable : $data");
525 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
528 # add \n
529 # Response expected: yes. Add a file or directory. This uses any previous
530 # Argument, Directory, Entry, or Modified requests, if they have been sent.
531 # The last Directory sent specifies the working directory at the time of
532 # the operation. To add a directory, send the directory to be added using
533 # Directory and Argument requests.
534 sub req_add
536 my ( $cmd, $data ) = @_;
538 argsplit("add");
540 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
541 $updater->update();
543 argsfromdir($updater);
545 my $addcount = 0;
547 foreach my $filename ( @{$state->{args}} )
549 $filename = filecleanup($filename);
551 my $meta = $updater->getmeta($filename);
552 my $wrev = revparse($filename);
554 if ($wrev && $meta && ($wrev < 0))
556 # previously removed file, add back
557 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
559 print "MT +updated\n";
560 print "MT text U \n";
561 print "MT fname $filename\n";
562 print "MT newline\n";
563 print "MT -updated\n";
565 unless ( $state->{globaloptions}{-n} )
567 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
569 print "Created $dirpart\n";
570 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
572 # this is an "entries" line
573 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
574 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
575 print "/$filepart/1.$meta->{revision}//$kopts/\n";
576 # permissions
577 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
578 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
579 # transmit file
580 transmitfile($meta->{filehash});
583 next;
586 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
588 print "E cvs add: nothing known about `$filename'\n";
589 next;
591 # TODO : check we're not squashing an already existing file
592 if ( defined ( $state->{entries}{$filename}{revision} ) )
594 print "E cvs add: `$filename' has already been entered\n";
595 next;
598 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
600 print "E cvs add: scheduling file `$filename' for addition\n";
602 print "Checked-in $dirpart\n";
603 print "$filename\n";
604 my $kopts = kopts_from_path($filename,"file",
605 $state->{entries}{$filename}{modified_filename});
606 print "/$filepart/0//$kopts/\n";
608 my $requestedKopts = $state->{opt}{k};
609 if(defined($requestedKopts))
611 $requestedKopts = "-k$requestedKopts";
613 else
615 $requestedKopts = "";
617 if( $kopts ne $requestedKopts )
619 $log->warn("Ignoring requested -k='$requestedKopts'"
620 . " for '$filename'; detected -k='$kopts' instead");
621 #TODO: Also have option to send warning to user?
624 $addcount++;
627 if ( $addcount == 1 )
629 print "E cvs add: use `cvs commit' to add this file permanently\n";
631 elsif ( $addcount > 1 )
633 print "E cvs add: use `cvs commit' to add these files permanently\n";
636 print "ok\n";
639 # remove \n
640 # Response expected: yes. Remove a file. This uses any previous Argument,
641 # Directory, Entry, or Modified requests, if they have been sent. The last
642 # Directory sent specifies the working directory at the time of the
643 # operation. Note that this request does not actually do anything to the
644 # repository; the only effect of a successful remove request is to supply
645 # the client with a new entries line containing `-' to indicate a removed
646 # file. In fact, the client probably could perform this operation without
647 # contacting the server, although using remove may cause the server to
648 # perform a few more checks. The client sends a subsequent ci request to
649 # actually record the removal in the repository.
650 sub req_remove
652 my ( $cmd, $data ) = @_;
654 argsplit("remove");
656 # Grab a handle to the SQLite db and do any necessary updates
657 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
658 $updater->update();
660 #$log->debug("add state : " . Dumper($state));
662 my $rmcount = 0;
664 foreach my $filename ( @{$state->{args}} )
666 $filename = filecleanup($filename);
668 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
670 print "E cvs remove: file `$filename' still in working directory\n";
671 next;
674 my $meta = $updater->getmeta($filename);
675 my $wrev = revparse($filename);
677 unless ( defined ( $wrev ) )
679 print "E cvs remove: nothing known about `$filename'\n";
680 next;
683 if ( defined($wrev) and $wrev < 0 )
685 print "E cvs remove: file `$filename' already scheduled for removal\n";
686 next;
689 unless ( $wrev == $meta->{revision} )
691 # TODO : not sure if the format of this message is quite correct.
692 print "E cvs remove: Up to date check failed for `$filename'\n";
693 next;
697 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
699 print "E cvs remove: scheduling `$filename' for removal\n";
701 print "Checked-in $dirpart\n";
702 print "$filename\n";
703 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
704 print "/$filepart/-1.$wrev//$kopts/\n";
706 $rmcount++;
709 if ( $rmcount == 1 )
711 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
713 elsif ( $rmcount > 1 )
715 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
718 print "ok\n";
721 # Modified filename \n
722 # Response expected: no. Additional data: mode, \n, file transmission. Send
723 # the server a copy of one locally modified file. filename is a file within
724 # the most recent directory sent with Directory; it must not contain `/'.
725 # If the user is operating on only some files in a directory, only those
726 # files need to be included. This can also be sent without Entry, if there
727 # is no entry for the file.
728 sub req_Modified
730 my ( $cmd, $data ) = @_;
732 my $mode = <STDIN>;
733 defined $mode
734 or (print "E end of file reading mode for $data\n"), return;
735 chomp $mode;
736 my $size = <STDIN>;
737 defined $size
738 or (print "E end of file reading size of $data\n"), return;
739 chomp $size;
741 # Grab config information
742 my $blocksize = 8192;
743 my $bytesleft = $size;
744 my $tmp;
746 # Get a filehandle/name to write it to
747 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
749 # Loop over file data writing out to temporary file.
750 while ( $bytesleft )
752 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
753 read STDIN, $tmp, $blocksize;
754 print $fh $tmp;
755 $bytesleft -= $blocksize;
758 close $fh
759 or (print "E failed to write temporary, $filename: $!\n"), return;
761 # Ensure we have something sensible for the file mode
762 if ( $mode =~ /u=(\w+)/ )
764 $mode = $1;
765 } else {
766 $mode = "rw";
769 # Save the file data in $state
770 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
771 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
772 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
773 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
775 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
778 # Unchanged filename \n
779 # Response expected: no. Tell the server that filename has not been
780 # modified in the checked out directory. The filename is a file within the
781 # most recent directory sent with Directory; it must not contain `/'.
782 sub req_Unchanged
784 my ( $cmd, $data ) = @_;
786 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
788 #$log->debug("req_Unchanged : $data");
791 # Argument text \n
792 # Response expected: no. Save argument for use in a subsequent command.
793 # Arguments accumulate until an argument-using command is given, at which
794 # point they are forgotten.
795 # Argumentx text \n
796 # Response expected: no. Append \n followed by text to the current argument
797 # being saved.
798 sub req_Argument
800 my ( $cmd, $data ) = @_;
802 # Argumentx means: append to last Argument (with a newline in front)
804 $log->debug("$cmd : $data");
806 if ( $cmd eq 'Argumentx') {
807 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
808 } else {
809 push @{$state->{arguments}}, $data;
813 # expand-modules \n
814 # Response expected: yes. Expand the modules which are specified in the
815 # arguments. Returns the data in Module-expansion responses. Note that the
816 # server can assume that this is checkout or export, not rtag or rdiff; the
817 # latter do not access the working directory and thus have no need to
818 # expand modules on the client side. Expand may not be the best word for
819 # what this request does. It does not necessarily tell you all the files
820 # contained in a module, for example. Basically it is a way of telling you
821 # which working directories the server needs to know about in order to
822 # handle a checkout of the specified modules. For example, suppose that the
823 # server has a module defined by
824 # aliasmodule -a 1dir
825 # That is, one can check out aliasmodule and it will take 1dir in the
826 # repository and check it out to 1dir in the working directory. Now suppose
827 # the client already has this module checked out and is planning on using
828 # the co request to update it. Without using expand-modules, the client
829 # would have two bad choices: it could either send information about all
830 # working directories under the current directory, which could be
831 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
832 # stands for 1dir, and neglect to send information for 1dir, which would
833 # lead to incorrect operation. With expand-modules, the client would first
834 # ask for the module to be expanded:
835 sub req_expandmodules
837 my ( $cmd, $data ) = @_;
839 argsplit();
841 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
843 unless ( ref $state->{arguments} eq "ARRAY" )
845 print "ok\n";
846 return;
849 foreach my $module ( @{$state->{arguments}} )
851 $log->debug("SEND : Module-expansion $module");
852 print "Module-expansion $module\n";
855 print "ok\n";
856 statecleanup();
859 # co \n
860 # Response expected: yes. Get files from the repository. This uses any
861 # previous Argument, Directory, Entry, or Modified requests, if they have
862 # been sent. Arguments to this command are module names; the client cannot
863 # know what directories they correspond to except by (1) just sending the
864 # co request, and then seeing what directory names the server sends back in
865 # its responses, and (2) the expand-modules request.
866 sub req_co
868 my ( $cmd, $data ) = @_;
870 argsplit("co");
872 # Provide list of modules, if -c was used.
873 if (exists $state->{opt}{c}) {
874 my $showref = `git show-ref --heads`;
875 for my $line (split '\n', $showref) {
876 if ( $line =~ m% refs/heads/(.*)$% ) {
877 print "M $1\t$1\n";
880 print "ok\n";
881 return 1;
884 my $module = $state->{args}[0];
885 $state->{module} = $module;
886 my $checkout_path = $module;
888 # use the user specified directory if we're given it
889 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
891 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
893 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
895 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
897 # Grab a handle to the SQLite db and do any necessary updates
898 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
899 $updater->update();
901 $checkout_path =~ s|/$||; # get rid of trailing slashes
903 # Eclipse seems to need the Clear-sticky command
904 # to prepare the 'Entries' file for the new directory.
905 print "Clear-sticky $checkout_path/\n";
906 print $state->{CVSROOT} . "/$module/\n";
907 print "Clear-static-directory $checkout_path/\n";
908 print $state->{CVSROOT} . "/$module/\n";
909 print "Clear-sticky $checkout_path/\n"; # yes, twice
910 print $state->{CVSROOT} . "/$module/\n";
911 print "Template $checkout_path/\n";
912 print $state->{CVSROOT} . "/$module/\n";
913 print "0\n";
915 # instruct the client that we're checking out to $checkout_path
916 print "E cvs checkout: Updating $checkout_path\n";
918 my %seendirs = ();
919 my $lastdir ='';
921 # recursive
922 sub prepdir {
923 my ($dir, $repodir, $remotedir, $seendirs) = @_;
924 my $parent = dirname($dir);
925 $dir =~ s|/+$||;
926 $repodir =~ s|/+$||;
927 $remotedir =~ s|/+$||;
928 $parent =~ s|/+$||;
929 $log->debug("announcedir $dir, $repodir, $remotedir" );
931 if ($parent eq '.' || $parent eq './') {
932 $parent = '';
934 # recurse to announce unseen parents first
935 if (length($parent) && !exists($seendirs->{$parent})) {
936 prepdir($parent, $repodir, $remotedir, $seendirs);
938 # Announce that we are going to modify at the parent level
939 if ($parent) {
940 print "E cvs checkout: Updating $remotedir/$parent\n";
941 } else {
942 print "E cvs checkout: Updating $remotedir\n";
944 print "Clear-sticky $remotedir/$parent/\n";
945 print "$repodir/$parent/\n";
947 print "Clear-static-directory $remotedir/$dir/\n";
948 print "$repodir/$dir/\n";
949 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
950 print "$repodir/$parent/\n";
951 print "Template $remotedir/$dir/\n";
952 print "$repodir/$dir/\n";
953 print "0\n";
955 $seendirs->{$dir} = 1;
958 foreach my $git ( @{$updater->gethead} )
960 # Don't want to check out deleted files
961 next if ( $git->{filehash} eq "deleted" );
963 my $fullName = $git->{name};
964 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
966 if (length($git->{dir}) && $git->{dir} ne './'
967 && $git->{dir} ne $lastdir ) {
968 unless (exists($seendirs{$git->{dir}})) {
969 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
970 $checkout_path, \%seendirs);
971 $lastdir = $git->{dir};
972 $seendirs{$git->{dir}} = 1;
974 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
977 # modification time of this file
978 print "Mod-time $git->{modified}\n";
980 # print some information to the client
981 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
983 print "M U $checkout_path/$git->{dir}$git->{name}\n";
984 } else {
985 print "M U $checkout_path/$git->{name}\n";
988 # instruct client we're sending a file to put in this path
989 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
991 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
993 # this is an "entries" line
994 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
995 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
996 # permissions
997 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
999 # transmit file
1000 transmitfile($git->{filehash});
1003 print "ok\n";
1005 statecleanup();
1008 # update \n
1009 # Response expected: yes. Actually do a cvs update command. This uses any
1010 # previous Argument, Directory, Entry, or Modified requests, if they have
1011 # been sent. The last Directory sent specifies the working directory at the
1012 # time of the operation. The -I option is not used--files which the client
1013 # can decide whether to ignore are not mentioned and the client sends the
1014 # Questionable request for others.
1015 sub req_update
1017 my ( $cmd, $data ) = @_;
1019 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1021 argsplit("update");
1024 # It may just be a client exploring the available heads/modules
1025 # in that case, list them as top level directories and leave it
1026 # at that. Eclipse uses this technique to offer you a list of
1027 # projects (heads in this case) to checkout.
1029 if ($state->{module} eq '') {
1030 my $showref = `git show-ref --heads`;
1031 print "E cvs update: Updating .\n";
1032 for my $line (split '\n', $showref) {
1033 if ( $line =~ m% refs/heads/(.*)$% ) {
1034 print "E cvs update: New directory `$1'\n";
1037 print "ok\n";
1038 return 1;
1042 # Grab a handle to the SQLite db and do any necessary updates
1043 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1045 $updater->update();
1047 argsfromdir($updater);
1049 #$log->debug("update state : " . Dumper($state));
1051 my $last_dirname = "///";
1053 # foreach file specified on the command line ...
1054 foreach my $filename ( @{$state->{args}} )
1056 $filename = filecleanup($filename);
1058 $log->debug("Processing file $filename");
1060 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1062 my $cur_dirname = dirname($filename);
1063 if ( $cur_dirname ne $last_dirname )
1065 $last_dirname = $cur_dirname;
1066 if ( $cur_dirname eq "" )
1068 $cur_dirname = ".";
1070 print "E cvs update: Updating $cur_dirname\n";
1074 # if we have a -C we should pretend we never saw modified stuff
1075 if ( exists ( $state->{opt}{C} ) )
1077 delete $state->{entries}{$filename}{modified_hash};
1078 delete $state->{entries}{$filename}{modified_filename};
1079 $state->{entries}{$filename}{unchanged} = 1;
1082 my $meta;
1083 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1085 $meta = $updater->getmeta($filename, $1);
1086 } else {
1087 $meta = $updater->getmeta($filename);
1090 # If -p was given, "print" the contents of the requested revision.
1091 if ( exists ( $state->{opt}{p} ) ) {
1092 if ( defined ( $meta->{revision} ) ) {
1093 $log->info("Printing '$filename' revision " . $meta->{revision});
1095 transmitfile($meta->{filehash}, { print => 1 });
1098 next;
1101 if ( ! defined $meta )
1103 $meta = {
1104 name => $filename,
1105 revision => 0,
1106 filehash => 'added'
1110 my $oldmeta = $meta;
1112 my $wrev = revparse($filename);
1114 # If the working copy is an old revision, lets get that version too for comparison.
1115 if ( defined($wrev) and $wrev != $meta->{revision} )
1117 $oldmeta = $updater->getmeta($filename, $wrev);
1120 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1122 # Files are up to date if the working copy and repo copy have the same revision,
1123 # and the working copy is unmodified _and_ the user hasn't specified -C
1124 next if ( defined ( $wrev )
1125 and defined($meta->{revision})
1126 and $wrev == $meta->{revision}
1127 and $state->{entries}{$filename}{unchanged}
1128 and not exists ( $state->{opt}{C} ) );
1130 # If the working copy and repo copy have the same revision,
1131 # but the working copy is modified, tell the client it's modified
1132 if ( defined ( $wrev )
1133 and defined($meta->{revision})
1134 and $wrev == $meta->{revision}
1135 and defined($state->{entries}{$filename}{modified_hash})
1136 and not exists ( $state->{opt}{C} ) )
1138 $log->info("Tell the client the file is modified");
1139 print "MT text M \n";
1140 print "MT fname $filename\n";
1141 print "MT newline\n";
1142 next;
1145 if ( $meta->{filehash} eq "deleted" )
1147 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1149 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1151 print "E cvs update: `$filename' is no longer in the repository\n";
1152 # Don't want to actually _DO_ the update if -n specified
1153 unless ( $state->{globaloptions}{-n} ) {
1154 print "Removed $dirpart\n";
1155 print "$filepart\n";
1158 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1159 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1160 or $meta->{filehash} eq 'added' )
1162 # normal update, just send the new revision (either U=Update,
1163 # or A=Add, or R=Remove)
1164 if ( defined($wrev) && $wrev < 0 )
1166 $log->info("Tell the client the file is scheduled for removal");
1167 print "MT text R \n";
1168 print "MT fname $filename\n";
1169 print "MT newline\n";
1170 next;
1172 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1174 $log->info("Tell the client the file is scheduled for addition");
1175 print "MT text A \n";
1176 print "MT fname $filename\n";
1177 print "MT newline\n";
1178 next;
1181 else {
1182 $log->info("Updating '$filename' to ".$meta->{revision});
1183 print "MT +updated\n";
1184 print "MT text U \n";
1185 print "MT fname $filename\n";
1186 print "MT newline\n";
1187 print "MT -updated\n";
1190 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1192 # Don't want to actually _DO_ the update if -n specified
1193 unless ( $state->{globaloptions}{-n} )
1195 if ( defined ( $wrev ) )
1197 # instruct client we're sending a file to put in this path as a replacement
1198 print "Update-existing $dirpart\n";
1199 $log->debug("Updating existing file 'Update-existing $dirpart'");
1200 } else {
1201 # instruct client we're sending a file to put in this path as a new file
1202 print "Clear-static-directory $dirpart\n";
1203 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1204 print "Clear-sticky $dirpart\n";
1205 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1207 $log->debug("Creating new file 'Created $dirpart'");
1208 print "Created $dirpart\n";
1210 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1212 # this is an "entries" line
1213 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1214 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1215 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1217 # permissions
1218 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1219 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1221 # transmit file
1222 transmitfile($meta->{filehash});
1224 } else {
1225 $log->info("Updating '$filename'");
1226 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1228 my $mergeDir = setupTmpDir();
1230 my $file_local = $filepart . ".mine";
1231 my $mergedFile = "$mergeDir/$file_local";
1232 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1233 my $file_old = $filepart . "." . $oldmeta->{revision};
1234 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1235 my $file_new = $filepart . "." . $meta->{revision};
1236 transmitfile($meta->{filehash}, { targetfile => $file_new });
1238 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1239 $log->info("Merging $file_local, $file_old, $file_new");
1240 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1242 $log->debug("Temporary directory for merge is $mergeDir");
1244 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1245 $return >>= 8;
1247 cleanupTmpDir();
1249 if ( $return == 0 )
1251 $log->info("Merged successfully");
1252 print "M M $filename\n";
1253 $log->debug("Merged $dirpart");
1255 # Don't want to actually _DO_ the update if -n specified
1256 unless ( $state->{globaloptions}{-n} )
1258 print "Merged $dirpart\n";
1259 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1260 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1261 my $kopts = kopts_from_path("$dirpart/$filepart",
1262 "file",$mergedFile);
1263 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1264 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1267 elsif ( $return == 1 )
1269 $log->info("Merged with conflicts");
1270 print "E cvs update: conflicts found in $filename\n";
1271 print "M C $filename\n";
1273 # Don't want to actually _DO_ the update if -n specified
1274 unless ( $state->{globaloptions}{-n} )
1276 print "Merged $dirpart\n";
1277 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1278 my $kopts = kopts_from_path("$dirpart/$filepart",
1279 "file",$mergedFile);
1280 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1283 else
1285 $log->warn("Merge failed");
1286 next;
1289 # Don't want to actually _DO_ the update if -n specified
1290 unless ( $state->{globaloptions}{-n} )
1292 # permissions
1293 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1294 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1296 # transmit file, format is single integer on a line by itself (file
1297 # size) followed by the file contents
1298 # TODO : we should copy files in blocks
1299 my $data = `cat $mergedFile`;
1300 $log->debug("File size : " . length($data));
1301 print length($data) . "\n";
1302 print $data;
1308 print "ok\n";
1311 sub req_ci
1313 my ( $cmd, $data ) = @_;
1315 argsplit("ci");
1317 #$log->debug("State : " . Dumper($state));
1319 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1321 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1323 print "error 1 anonymous user cannot commit via pserver\n";
1324 cleanupWorkTree();
1325 exit;
1328 if ( -e $state->{CVSROOT} . "/index" )
1330 $log->warn("file 'index' already exists in the git repository");
1331 print "error 1 Index already exists in git repo\n";
1332 cleanupWorkTree();
1333 exit;
1336 # Grab a handle to the SQLite db and do any necessary updates
1337 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1338 $updater->update();
1340 # Remember where the head was at the beginning.
1341 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1342 chomp $parenthash;
1343 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1344 print "error 1 pserver cannot find the current HEAD of module";
1345 cleanupWorkTree();
1346 exit;
1349 setupWorkTree($parenthash);
1351 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1353 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1355 my @committedfiles = ();
1356 my %oldmeta;
1358 # foreach file specified on the command line ...
1359 foreach my $filename ( @{$state->{args}} )
1361 my $committedfile = $filename;
1362 $filename = filecleanup($filename);
1364 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1366 my $meta = $updater->getmeta($filename);
1367 $oldmeta{$filename} = $meta;
1369 my $wrev = revparse($filename);
1371 my ( $filepart, $dirpart ) = filenamesplit($filename);
1373 # do a checkout of the file if it is part of this tree
1374 if ($wrev) {
1375 system('git', 'checkout-index', '-f', '-u', $filename);
1376 unless ($? == 0) {
1377 die "Error running git-checkout-index -f -u $filename : $!";
1381 my $addflag = 0;
1382 my $rmflag = 0;
1383 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1384 $addflag = 1 unless ( -e $filename );
1386 # Do up to date checking
1387 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1389 # fail everything if an up to date check fails
1390 print "error 1 Up to date check failed for $filename\n";
1391 cleanupWorkTree();
1392 exit;
1395 push @committedfiles, $committedfile;
1396 $log->info("Committing $filename");
1398 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1400 unless ( $rmflag )
1402 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1403 rename $state->{entries}{$filename}{modified_filename},$filename;
1405 # Calculate modes to remove
1406 my $invmode = "";
1407 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1409 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1410 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1413 if ( $rmflag )
1415 $log->info("Removing file '$filename'");
1416 unlink($filename);
1417 system("git", "update-index", "--remove", $filename);
1419 elsif ( $addflag )
1421 $log->info("Adding file '$filename'");
1422 system("git", "update-index", "--add", $filename);
1423 } else {
1424 $log->info("Updating file '$filename'");
1425 system("git", "update-index", $filename);
1429 unless ( scalar(@committedfiles) > 0 )
1431 print "E No files to commit\n";
1432 print "ok\n";
1433 cleanupWorkTree();
1434 return;
1437 my $treehash = `git write-tree`;
1438 chomp $treehash;
1440 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1442 # write our commit message out if we have one ...
1443 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1444 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1445 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1446 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1447 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1449 } else {
1450 print $msg_fh "\n\nvia git-CVS emulator\n";
1452 close $msg_fh;
1454 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1455 chomp($commithash);
1456 $log->info("Commit hash : $commithash");
1458 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1460 $log->warn("Commit failed (Invalid commit hash)");
1461 print "error 1 Commit failed (unknown reason)\n";
1462 cleanupWorkTree();
1463 exit;
1466 ### Emulate git-receive-pack by running hooks/update
1467 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1468 $parenthash, $commithash );
1469 if( -x $hook[0] ) {
1470 unless( system( @hook ) == 0 )
1472 $log->warn("Commit failed (update hook declined to update ref)");
1473 print "error 1 Commit failed (update hook declined)\n";
1474 cleanupWorkTree();
1475 exit;
1479 ### Update the ref
1480 if (system(qw(git update-ref -m), "cvsserver ci",
1481 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1482 $log->warn("update-ref for $state->{module} failed.");
1483 print "error 1 Cannot commit -- update first\n";
1484 cleanupWorkTree();
1485 exit;
1488 ### Emulate git-receive-pack by running hooks/post-receive
1489 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1490 if( -x $hook ) {
1491 open(my $pipe, "| $hook") || die "can't fork $!";
1493 local $SIG{PIPE} = sub { die 'pipe broke' };
1495 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1497 close $pipe || die "bad pipe: $! $?";
1500 $updater->update();
1502 ### Then hooks/post-update
1503 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1504 if (-x $hook) {
1505 system($hook, "refs/heads/$state->{module}");
1508 # foreach file specified on the command line ...
1509 foreach my $filename ( @committedfiles )
1511 $filename = filecleanup($filename);
1513 my $meta = $updater->getmeta($filename);
1514 unless (defined $meta->{revision}) {
1515 $meta->{revision} = 1;
1518 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1520 $log->debug("Checked-in $dirpart : $filename");
1522 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1523 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1525 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1526 print "Remove-entry $dirpart\n";
1527 print "$filename\n";
1528 } else {
1529 if ($meta->{revision} == 1) {
1530 print "M initial revision: 1.1\n";
1531 } else {
1532 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1534 print "Checked-in $dirpart\n";
1535 print "$filename\n";
1536 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1537 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1541 cleanupWorkTree();
1542 print "ok\n";
1545 sub req_status
1547 my ( $cmd, $data ) = @_;
1549 argsplit("status");
1551 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1552 #$log->debug("status state : " . Dumper($state));
1554 # Grab a handle to the SQLite db and do any necessary updates
1555 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1556 $updater->update();
1558 # if no files were specified, we need to work out what files we should be providing status on ...
1559 argsfromdir($updater);
1561 # foreach file specified on the command line ...
1562 foreach my $filename ( @{$state->{args}} )
1564 $filename = filecleanup($filename);
1566 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1568 my $meta = $updater->getmeta($filename);
1569 my $oldmeta = $meta;
1571 my $wrev = revparse($filename);
1573 # If the working copy is an old revision, lets get that version too for comparison.
1574 if ( defined($wrev) and $wrev != $meta->{revision} )
1576 $oldmeta = $updater->getmeta($filename, $wrev);
1579 # TODO : All possible statuses aren't yet implemented
1580 my $status;
1581 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1582 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1584 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1585 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1588 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1589 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1591 ( $state->{entries}{$filename}{unchanged}
1592 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1595 # Need checkout if it exists in the repo but doesn't have a working copy
1596 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1598 # Locally modified if working copy and repo copy have the same revision but there are local changes
1599 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1601 # Needs Merge if working copy revision is less than repo copy and there are local changes
1602 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1604 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1605 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1606 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1607 $status ||= "File had conflicts on merge" if ( 0 );
1609 $status ||= "Unknown";
1611 my ($filepart) = filenamesplit($filename);
1613 print "M ===================================================================\n";
1614 print "M File: $filepart\tStatus: $status\n";
1615 if ( defined($state->{entries}{$filename}{revision}) )
1617 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1618 } else {
1619 print "M Working revision:\tNo entry for $filename\n";
1621 if ( defined($meta->{revision}) )
1623 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1624 print "M Sticky Tag:\t\t(none)\n";
1625 print "M Sticky Date:\t\t(none)\n";
1626 print "M Sticky Options:\t\t(none)\n";
1627 } else {
1628 print "M Repository revision:\tNo revision control file\n";
1630 print "M\n";
1633 print "ok\n";
1636 sub req_diff
1638 my ( $cmd, $data ) = @_;
1640 argsplit("diff");
1642 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1643 #$log->debug("status state : " . Dumper($state));
1645 my ($revision1, $revision2);
1646 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1648 $revision1 = $state->{opt}{r}[0];
1649 $revision2 = $state->{opt}{r}[1];
1650 } else {
1651 $revision1 = $state->{opt}{r};
1654 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1655 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1657 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1659 # Grab a handle to the SQLite db and do any necessary updates
1660 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1661 $updater->update();
1663 # if no files were specified, we need to work out what files we should be providing status on ...
1664 argsfromdir($updater);
1666 # foreach file specified on the command line ...
1667 foreach my $filename ( @{$state->{args}} )
1669 $filename = filecleanup($filename);
1671 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1673 my $wrev = revparse($filename);
1675 # We need _something_ to diff against
1676 next unless ( defined ( $wrev ) );
1678 # if we have a -r switch, use it
1679 if ( defined ( $revision1 ) )
1681 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1682 $meta1 = $updater->getmeta($filename, $revision1);
1683 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1685 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1686 next;
1688 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1690 # otherwise we just use the working copy revision
1691 else
1693 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1694 $meta1 = $updater->getmeta($filename, $wrev);
1695 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1698 # if we have a second -r switch, use it too
1699 if ( defined ( $revision2 ) )
1701 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1702 $meta2 = $updater->getmeta($filename, $revision2);
1704 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1706 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1707 next;
1710 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1712 # otherwise we just use the working copy
1713 else
1715 $file2 = $state->{entries}{$filename}{modified_filename};
1718 # if we have been given -r, and we don't have a $file2 yet, lets get one
1719 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1721 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1722 $meta2 = $updater->getmeta($filename, $wrev);
1723 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1726 # We need to have retrieved something useful
1727 next unless ( defined ( $meta1 ) );
1729 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1730 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1732 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1733 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1736 # Apparently we only show diffs for locally modified files
1737 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1739 print "M Index: $filename\n";
1740 print "M ===================================================================\n";
1741 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1742 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1743 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1744 print "M diff ";
1745 foreach my $opt ( keys %{$state->{opt}} )
1747 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1749 foreach my $value ( @{$state->{opt}{$opt}} )
1751 print "-$opt $value ";
1753 } else {
1754 print "-$opt ";
1755 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1758 print "$filename\n";
1760 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1762 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1764 if ( exists $state->{opt}{u} )
1766 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1767 } else {
1768 system("diff $file1 $file2 > $filediff");
1771 while ( <$fh> )
1773 print "M $_";
1775 close $fh;
1778 print "ok\n";
1781 sub req_log
1783 my ( $cmd, $data ) = @_;
1785 argsplit("log");
1787 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1788 #$log->debug("log state : " . Dumper($state));
1790 my ( $minrev, $maxrev );
1791 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1793 my $control = $2;
1794 $minrev = $1;
1795 $maxrev = $3;
1796 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1797 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1798 $minrev++ if ( defined($minrev) and $control eq "::" );
1801 # Grab a handle to the SQLite db and do any necessary updates
1802 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1803 $updater->update();
1805 # if no files were specified, we need to work out what files we should be providing status on ...
1806 argsfromdir($updater);
1808 # foreach file specified on the command line ...
1809 foreach my $filename ( @{$state->{args}} )
1811 $filename = filecleanup($filename);
1813 my $headmeta = $updater->getmeta($filename);
1815 my $revisions = $updater->getlog($filename);
1816 my $totalrevisions = scalar(@$revisions);
1818 if ( defined ( $minrev ) )
1820 $log->debug("Removing revisions less than $minrev");
1821 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1823 pop @$revisions;
1826 if ( defined ( $maxrev ) )
1828 $log->debug("Removing revisions greater than $maxrev");
1829 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1831 shift @$revisions;
1835 next unless ( scalar(@$revisions) );
1837 print "M \n";
1838 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1839 print "M Working file: $filename\n";
1840 print "M head: 1.$headmeta->{revision}\n";
1841 print "M branch:\n";
1842 print "M locks: strict\n";
1843 print "M access list:\n";
1844 print "M symbolic names:\n";
1845 print "M keyword substitution: kv\n";
1846 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1847 print "M description:\n";
1849 foreach my $revision ( @$revisions )
1851 print "M ----------------------------\n";
1852 print "M revision 1.$revision->{revision}\n";
1853 # reformat the date for log output
1854 $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}) );
1855 $revision->{author} = cvs_author($revision->{author});
1856 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1857 my $commitmessage = $updater->commitmessage($revision->{commithash});
1858 $commitmessage =~ s/^/M /mg;
1859 print $commitmessage . "\n";
1861 print "M =============================================================================\n";
1864 print "ok\n";
1867 sub req_annotate
1869 my ( $cmd, $data ) = @_;
1871 argsplit("annotate");
1873 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1874 #$log->debug("status state : " . Dumper($state));
1876 # Grab a handle to the SQLite db and do any necessary updates
1877 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1878 $updater->update();
1880 # if no files were specified, we need to work out what files we should be providing annotate on ...
1881 argsfromdir($updater);
1883 # we'll need a temporary checkout dir
1884 setupWorkTree();
1886 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1888 # foreach file specified on the command line ...
1889 foreach my $filename ( @{$state->{args}} )
1891 $filename = filecleanup($filename);
1893 my $meta = $updater->getmeta($filename);
1895 next unless ( $meta->{revision} );
1897 # get all the commits that this file was in
1898 # in dense format -- aka skip dead revisions
1899 my $revisions = $updater->gethistorydense($filename);
1900 my $lastseenin = $revisions->[0][2];
1902 # populate the temporary index based on the latest commit were we saw
1903 # the file -- but do it cheaply without checking out any files
1904 # TODO: if we got a revision from the client, use that instead
1905 # to look up the commithash in sqlite (still good to default to
1906 # the current head as we do now)
1907 system("git", "read-tree", $lastseenin);
1908 unless ($? == 0)
1910 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1911 return;
1913 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1915 # do a checkout of the file
1916 system('git', 'checkout-index', '-f', '-u', $filename);
1917 unless ($? == 0) {
1918 print "E error running git-checkout-index -f -u $filename : $!\n";
1919 return;
1922 $log->info("Annotate $filename");
1924 # Prepare a file with the commits from the linearized
1925 # history that annotate should know about. This prevents
1926 # git-jsannotate telling us about commits we are hiding
1927 # from the client.
1929 my $a_hints = "$work->{workDir}/.annotate_hints";
1930 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1931 print "E failed to open '$a_hints' for writing: $!\n";
1932 return;
1934 for (my $i=0; $i < @$revisions; $i++)
1936 print ANNOTATEHINTS $revisions->[$i][2];
1937 if ($i+1 < @$revisions) { # have we got a parent?
1938 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1940 print ANNOTATEHINTS "\n";
1943 print ANNOTATEHINTS "\n";
1944 close ANNOTATEHINTS
1945 or (print "E failed to write $a_hints: $!\n"), return;
1947 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1948 if (!open(ANNOTATE, "-|", @cmd)) {
1949 print "E error invoking ". join(' ',@cmd) .": $!\n";
1950 return;
1952 my $metadata = {};
1953 print "E Annotations for $filename\n";
1954 print "E ***************\n";
1955 while ( <ANNOTATE> )
1957 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1959 my $commithash = $1;
1960 my $data = $2;
1961 unless ( defined ( $metadata->{$commithash} ) )
1963 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1964 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1965 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1967 printf("M 1.%-5d (%-8s %10s): %s\n",
1968 $metadata->{$commithash}{revision},
1969 $metadata->{$commithash}{author},
1970 $metadata->{$commithash}{modified},
1971 $data
1973 } else {
1974 $log->warn("Error in annotate output! LINE: $_");
1975 print "E Annotate error \n";
1976 next;
1979 close ANNOTATE;
1982 # done; get out of the tempdir
1983 cleanupWorkTree();
1985 print "ok\n";
1989 # This method takes the state->{arguments} array and produces two new arrays.
1990 # The first is $state->{args} which is everything before the '--' argument, and
1991 # the second is $state->{files} which is everything after it.
1992 sub argsplit
1994 $state->{args} = [];
1995 $state->{files} = [];
1996 $state->{opt} = {};
1998 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2000 my $type = shift;
2002 if ( defined($type) )
2004 my $opt = {};
2005 $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" );
2006 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2007 $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" );
2008 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2009 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2010 $opt = { k => 1, m => 1 } if ( $type eq "add" );
2011 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2012 $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" );
2015 while ( scalar ( @{$state->{arguments}} ) > 0 )
2017 my $arg = shift @{$state->{arguments}};
2019 next if ( $arg eq "--" );
2020 next unless ( $arg =~ /\S/ );
2022 # if the argument looks like a switch
2023 if ( $arg =~ /^-(\w)(.*)/ )
2025 # if it's a switch that takes an argument
2026 if ( $opt->{$1} )
2028 # If this switch has already been provided
2029 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2031 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2032 if ( length($2) > 0 )
2034 push @{$state->{opt}{$1}},$2;
2035 } else {
2036 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2038 } else {
2039 # if there's extra data in the arg, use that as the argument for the switch
2040 if ( length($2) > 0 )
2042 $state->{opt}{$1} = $2;
2043 } else {
2044 $state->{opt}{$1} = shift @{$state->{arguments}};
2047 } else {
2048 $state->{opt}{$1} = undef;
2051 else
2053 push @{$state->{args}}, $arg;
2057 else
2059 my $mode = 0;
2061 foreach my $value ( @{$state->{arguments}} )
2063 if ( $value eq "--" )
2065 $mode++;
2066 next;
2068 push @{$state->{args}}, $value if ( $mode == 0 );
2069 push @{$state->{files}}, $value if ( $mode == 1 );
2074 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2075 sub argsfromdir
2077 my $updater = shift;
2079 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2081 return if ( scalar ( @{$state->{args}} ) > 1 );
2083 my @gethead = @{$updater->gethead};
2085 # push added files
2086 foreach my $file (keys %{$state->{entries}}) {
2087 if ( exists $state->{entries}{$file}{revision} &&
2088 $state->{entries}{$file}{revision} == 0 )
2090 push @gethead, { name => $file, filehash => 'added' };
2094 if ( scalar(@{$state->{args}}) == 1 )
2096 my $arg = $state->{args}[0];
2097 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2099 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2101 foreach my $file ( @gethead )
2103 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2104 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2105 push @{$state->{args}}, $file->{name};
2108 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2109 } else {
2110 $log->info("Only one arg specified, populating file list automatically");
2112 $state->{args} = [];
2114 foreach my $file ( @gethead )
2116 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2117 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2118 push @{$state->{args}}, $file->{name};
2123 # This method cleans up the $state variable after a command that uses arguments has run
2124 sub statecleanup
2126 $state->{files} = [];
2127 $state->{args} = [];
2128 $state->{arguments} = [];
2129 $state->{entries} = {};
2132 sub revparse
2134 my $filename = shift;
2136 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2138 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2139 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2141 return undef;
2144 # This method takes a file hash and does a CVS "file transfer". Its
2145 # exact behaviour depends on a second, optional hash table argument:
2146 # - If $options->{targetfile}, dump the contents to that file;
2147 # - If $options->{print}, use M/MT to transmit the contents one line
2148 # at a time;
2149 # - Otherwise, transmit the size of the file, followed by the file
2150 # contents.
2151 sub transmitfile
2153 my $filehash = shift;
2154 my $options = shift;
2156 if ( defined ( $filehash ) and $filehash eq "deleted" )
2158 $log->warn("filehash is 'deleted'");
2159 return;
2162 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2164 my $type = `git cat-file -t $filehash`;
2165 chomp $type;
2167 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2169 my $size = `git cat-file -s $filehash`;
2170 chomp $size;
2172 $log->debug("transmitfile($filehash) size=$size, type=$type");
2174 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2176 if ( defined ( $options->{targetfile} ) )
2178 my $targetfile = $options->{targetfile};
2179 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2180 print NEWFILE $_ while ( <$fh> );
2181 close NEWFILE or die("Failed to write '$targetfile': $!");
2182 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2183 while ( <$fh> ) {
2184 if( /\n\z/ ) {
2185 print 'M ', $_;
2186 } else {
2187 print 'MT text ', $_, "\n";
2190 } else {
2191 print "$size\n";
2192 print while ( <$fh> );
2194 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2195 } else {
2196 die("Couldn't execute git-cat-file");
2200 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2201 # refers to the directory portion and the file portion of the filename
2202 # respectively
2203 sub filenamesplit
2205 my $filename = shift;
2206 my $fixforlocaldir = shift;
2208 my ( $filepart, $dirpart ) = ( $filename, "." );
2209 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2210 $dirpart .= "/";
2212 if ( $fixforlocaldir )
2214 $dirpart =~ s/^$state->{prependdir}//;
2217 return ( $filepart, $dirpart );
2220 sub filecleanup
2222 my $filename = shift;
2224 return undef unless(defined($filename));
2225 if ( $filename =~ /^\// )
2227 print "E absolute filenames '$filename' not supported by server\n";
2228 return undef;
2231 $filename =~ s/^\.\///g;
2232 $filename = $state->{prependdir} . $filename;
2233 return $filename;
2236 sub validateGitDir
2238 if( !defined($state->{CVSROOT}) )
2240 print "error 1 CVSROOT not specified\n";
2241 cleanupWorkTree();
2242 exit;
2244 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2246 print "error 1 Internally inconsistent CVSROOT\n";
2247 cleanupWorkTree();
2248 exit;
2252 # Setup working directory in a work tree with the requested version
2253 # loaded in the index.
2254 sub setupWorkTree
2256 my ($ver) = @_;
2258 validateGitDir();
2260 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2261 defined($work->{tmpDir}) )
2263 $log->warn("Bad work tree state management");
2264 print "error 1 Internal setup multiple work trees without cleanup\n";
2265 cleanupWorkTree();
2266 exit;
2269 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2271 if( !defined($work->{index}) )
2273 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2276 chdir $work->{workDir} or
2277 die "Unable to chdir to $work->{workDir}\n";
2279 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2281 $ENV{GIT_WORK_TREE} = ".";
2282 $ENV{GIT_INDEX_FILE} = $work->{index};
2283 $work->{state} = 2;
2285 if($ver)
2287 system("git","read-tree",$ver);
2288 unless ($? == 0)
2290 $log->warn("Error running git-read-tree");
2291 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2294 # else # req_annotate reads tree for each file
2297 # Ensure current directory is in some kind of working directory,
2298 # with a recent version loaded in the index.
2299 sub ensureWorkTree
2301 if( defined($work->{tmpDir}) )
2303 $log->warn("Bad work tree state management [ensureWorkTree()]");
2304 print "error 1 Internal setup multiple dirs without cleanup\n";
2305 cleanupWorkTree();
2306 exit;
2308 if( $work->{state} )
2310 return;
2313 validateGitDir();
2315 if( !defined($work->{emptyDir}) )
2317 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2319 chdir $work->{emptyDir} or
2320 die "Unable to chdir to $work->{emptyDir}\n";
2322 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2323 chomp $ver;
2324 if ($ver !~ /^[0-9a-f]{40}$/)
2326 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2327 print "error 1 cannot find the current HEAD of module";
2328 cleanupWorkTree();
2329 exit;
2332 if( !defined($work->{index}) )
2334 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2337 $ENV{GIT_WORK_TREE} = ".";
2338 $ENV{GIT_INDEX_FILE} = $work->{index};
2339 $work->{state} = 1;
2341 system("git","read-tree",$ver);
2342 unless ($? == 0)
2344 die "Error running git-read-tree $ver $!\n";
2348 # Cleanup working directory that is not needed any longer.
2349 sub cleanupWorkTree
2351 if( ! $work->{state} )
2353 return;
2356 chdir "/" or die "Unable to chdir '/'\n";
2358 if( defined($work->{workDir}) )
2360 rmtree( $work->{workDir} );
2361 undef $work->{workDir};
2363 undef $work->{state};
2366 # Setup a temporary directory (not a working tree), typically for
2367 # merging dirty state as in req_update.
2368 sub setupTmpDir
2370 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2371 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2373 return $work->{tmpDir};
2376 # Clean up a previously setupTmpDir. Restore previous work tree if
2377 # appropriate.
2378 sub cleanupTmpDir
2380 if ( !defined($work->{tmpDir}) )
2382 $log->warn("cleanup tmpdir that has not been setup");
2383 die "Cleanup tmpDir that has not been setup\n";
2385 if( defined($work->{state}) )
2387 if( $work->{state} == 1 )
2389 chdir $work->{emptyDir} or
2390 die "Unable to chdir to $work->{emptyDir}\n";
2392 elsif( $work->{state} == 2 )
2394 chdir $work->{workDir} or
2395 die "Unable to chdir to $work->{emptyDir}\n";
2397 else
2399 $log->warn("Inconsistent work dir state");
2400 die "Inconsistent work dir state\n";
2403 else
2405 chdir "/" or die "Unable to chdir '/'\n";
2409 # Given a path, this function returns a string containing the kopts
2410 # that should go into that path's Entries line. For example, a binary
2411 # file should get -kb.
2412 sub kopts_from_path
2414 my ($path, $srcType, $name) = @_;
2416 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2417 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2419 my ($val) = check_attr( "text", $path );
2420 if ( $val eq "unspecified" )
2422 $val = check_attr( "crlf", $path );
2424 if ( $val eq "unset" )
2426 return "-kb"
2428 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2429 $val eq "set" || $val eq "input" )
2431 return "";
2433 else
2435 $log->info("Unrecognized check_attr crlf $path : $val");
2439 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2441 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2443 return "-kb";
2445 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2447 if( $srcType eq "sha1Or-k" &&
2448 !defined($name) )
2450 my ($ret)=$state->{entries}{$path}{options};
2451 if( !defined($ret) )
2453 $ret=$state->{opt}{k};
2454 if(defined($ret))
2456 $ret="-k$ret";
2458 else
2460 $ret="";
2463 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2465 print "E Bad -k option\n";
2466 $log->warn("Bad -k option: $ret");
2467 die "Error: Bad -k option: $ret\n";
2470 return $ret;
2472 else
2474 if( is_binary($srcType,$name) )
2476 $log->debug("... as binary");
2477 return "-kb";
2479 else
2481 $log->debug("... as text");
2486 # Return "" to give no special treatment to any path
2487 return "";
2490 sub check_attr
2492 my ($attr,$path) = @_;
2493 ensureWorkTree();
2494 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2496 my $val = <$fh>;
2497 close $fh;
2498 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2499 return $val;
2501 else
2503 return undef;
2507 # This should have the same heuristics as convert.c:is_binary() and related.
2508 # Note that the bare CR test is done by callers in convert.c.
2509 sub is_binary
2511 my ($srcType,$name) = @_;
2512 $log->debug("is_binary($srcType,$name)");
2514 # Minimize amount of interpreted code run in the inner per-character
2515 # loop for large files, by totalling each character value and
2516 # then analyzing the totals.
2517 my @counts;
2518 my $i;
2519 for($i=0;$i<256;$i++)
2521 $counts[$i]=0;
2524 my $fh = open_blob_or_die($srcType,$name);
2525 my $line;
2526 while( defined($line=<$fh>) )
2528 # Any '\0' and bare CR are considered binary.
2529 if( $line =~ /\0|(\r[^\n])/ )
2531 close($fh);
2532 return 1;
2535 # Count up each character in the line:
2536 my $len=length($line);
2537 for($i=0;$i<$len;$i++)
2539 $counts[ord(substr($line,$i,1))]++;
2542 close $fh;
2544 # Don't count CR and LF as either printable/nonprintable
2545 $counts[ord("\n")]=0;
2546 $counts[ord("\r")]=0;
2548 # Categorize individual character count into printable and nonprintable:
2549 my $printable=0;
2550 my $nonprintable=0;
2551 for($i=0;$i<256;$i++)
2553 if( $i < 32 &&
2554 $i != ord("\b") &&
2555 $i != ord("\t") &&
2556 $i != 033 && # ESC
2557 $i != 014 ) # FF
2559 $nonprintable+=$counts[$i];
2561 elsif( $i==127 ) # DEL
2563 $nonprintable+=$counts[$i];
2565 else
2567 $printable+=$counts[$i];
2571 return ($printable >> 7) < $nonprintable;
2574 # Returns open file handle. Possible invocations:
2575 # - open_blob_or_die("file",$filename);
2576 # - open_blob_or_die("sha1",$filehash);
2577 sub open_blob_or_die
2579 my ($srcType,$name) = @_;
2580 my ($fh);
2581 if( $srcType eq "file" )
2583 if( !open $fh,"<",$name )
2585 $log->warn("Unable to open file $name: $!");
2586 die "Unable to open file $name: $!\n";
2589 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2591 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2593 $log->warn("Need filehash");
2594 die "Need filehash\n";
2597 my $type = `git cat-file -t $name`;
2598 chomp $type;
2600 unless ( defined ( $type ) and $type eq "blob" )
2602 $log->warn("Invalid type '$type' for '$name'");
2603 die ( "Invalid type '$type' (expected 'blob')" )
2606 my $size = `git cat-file -s $name`;
2607 chomp $size;
2609 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2611 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2613 $log->warn("Unable to open sha1 $name");
2614 die "Unable to open sha1 $name\n";
2617 else
2619 $log->warn("Unknown type of blob source: $srcType");
2620 die "Unknown type of blob source: $srcType\n";
2622 return $fh;
2625 # Generate a CVS author name from Git author information, by taking the local
2626 # part of the email address and replacing characters not in the Portable
2627 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2628 # Login names are Unix login names, which should be restricted to this
2629 # character set.
2630 sub cvs_author
2632 my $author_line = shift;
2633 (my $author) = $author_line =~ /<([^@>]*)/;
2635 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2636 $author =~ s/^-/_/;
2638 $author;
2642 sub descramble
2644 # This table is from src/scramble.c in the CVS source
2645 my @SHIFTS = (
2646 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2647 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2648 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2649 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2650 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2651 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2652 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2653 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2654 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2655 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2656 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2657 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2658 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2659 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2660 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2661 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2663 my ($str) = @_;
2665 # This should never happen, the same password format (A) has been
2666 # used by CVS since the beginning of time
2668 my $fmt = substr($str, 0, 1);
2669 die "invalid password format `$fmt'" unless $fmt eq 'A';
2672 my @str = unpack "C*", substr($str, 1);
2673 my $ret = join '', map { chr $SHIFTS[$_] } @str;
2674 return $ret;
2678 package GITCVS::log;
2680 ####
2681 #### Copyright The Open University UK - 2006.
2682 ####
2683 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2684 #### Martin Langhoff <martin@laptop.org>
2685 ####
2686 ####
2688 use strict;
2689 use warnings;
2691 =head1 NAME
2693 GITCVS::log
2695 =head1 DESCRIPTION
2697 This module provides very crude logging with a similar interface to
2698 Log::Log4perl
2700 =head1 METHODS
2702 =cut
2704 =head2 new
2706 Creates a new log object, optionally you can specify a filename here to
2707 indicate the file to log to. If no log file is specified, you can specify one
2708 later with method setfile, or indicate you no longer want logging with method
2709 nofile.
2711 Until one of these methods is called, all log calls will buffer messages ready
2712 to write out.
2714 =cut
2715 sub new
2717 my $class = shift;
2718 my $filename = shift;
2720 my $self = {};
2722 bless $self, $class;
2724 if ( defined ( $filename ) )
2726 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2729 return $self;
2732 =head2 setfile
2734 This methods takes a filename, and attempts to open that file as the log file.
2735 If successful, all buffered data is written out to the file, and any further
2736 logging is written directly to the file.
2738 =cut
2739 sub setfile
2741 my $self = shift;
2742 my $filename = shift;
2744 if ( defined ( $filename ) )
2746 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2749 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2751 while ( my $line = shift @{$self->{buffer}} )
2753 print {$self->{fh}} $line;
2757 =head2 nofile
2759 This method indicates no logging is going to be used. It flushes any entries in
2760 the internal buffer, and sets a flag to ensure no further data is put there.
2762 =cut
2763 sub nofile
2765 my $self = shift;
2767 $self->{nolog} = 1;
2769 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2771 $self->{buffer} = [];
2774 =head2 _logopen
2776 Internal method. Returns true if the log file is open, false otherwise.
2778 =cut
2779 sub _logopen
2781 my $self = shift;
2783 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2784 return 0;
2787 =head2 debug info warn fatal
2789 These four methods are wrappers to _log. They provide the actual interface for
2790 logging data.
2792 =cut
2793 sub debug { my $self = shift; $self->_log("debug", @_); }
2794 sub info { my $self = shift; $self->_log("info" , @_); }
2795 sub warn { my $self = shift; $self->_log("warn" , @_); }
2796 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2798 =head2 _log
2800 This is an internal method called by the logging functions. It generates a
2801 timestamp and pushes the logged line either to file, or internal buffer.
2803 =cut
2804 sub _log
2806 my $self = shift;
2807 my $level = shift;
2809 return if ( $self->{nolog} );
2811 my @time = localtime;
2812 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2813 $time[5] + 1900,
2814 $time[4] + 1,
2815 $time[3],
2816 $time[2],
2817 $time[1],
2818 $time[0],
2819 uc $level,
2822 if ( $self->_logopen )
2824 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2825 } else {
2826 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2830 =head2 DESTROY
2832 This method simply closes the file handle if one is open
2834 =cut
2835 sub DESTROY
2837 my $self = shift;
2839 if ( $self->_logopen )
2841 close $self->{fh};
2845 package GITCVS::updater;
2847 ####
2848 #### Copyright The Open University UK - 2006.
2849 ####
2850 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2851 #### Martin Langhoff <martin@laptop.org>
2852 ####
2853 ####
2855 use strict;
2856 use warnings;
2857 use DBI;
2859 =head1 METHODS
2861 =cut
2863 =head2 new
2865 =cut
2866 sub new
2868 my $class = shift;
2869 my $config = shift;
2870 my $module = shift;
2871 my $log = shift;
2873 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2874 die "Need to specify a module" unless ( defined($module) );
2876 $class = ref($class) || $class;
2878 my $self = {};
2880 bless $self, $class;
2882 $self->{valid_tables} = {'revision' => 1,
2883 'revision_ix1' => 1,
2884 'revision_ix2' => 1,
2885 'head' => 1,
2886 'head_ix1' => 1,
2887 'properties' => 1,
2888 'commitmsgs' => 1};
2890 $self->{module} = $module;
2891 $self->{git_path} = $config . "/";
2893 $self->{log} = $log;
2895 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2897 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2898 $cfg->{gitcvs}{dbdriver} || "SQLite";
2899 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2900 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2901 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2902 $cfg->{gitcvs}{dbuser} || "";
2903 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2904 $cfg->{gitcvs}{dbpass} || "";
2905 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2906 $cfg->{gitcvs}{dbtablenameprefix} || "";
2907 my %mapping = ( m => $module,
2908 a => $state->{method},
2909 u => getlogin || getpwuid($<) || $<,
2910 G => $self->{git_path},
2911 g => mangle_dirname($self->{git_path}),
2913 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2914 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2915 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2916 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2918 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2919 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2920 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2921 $self->{dbuser},
2922 $self->{dbpass});
2923 die "Error connecting to database\n" unless defined $self->{dbh};
2925 $self->{tables} = {};
2926 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2928 $self->{tables}{$table} = 1;
2931 # Construct the revision table if required
2932 unless ( $self->{tables}{$self->tablename("revision")} )
2934 my $tablename = $self->tablename("revision");
2935 my $ix1name = $self->tablename("revision_ix1");
2936 my $ix2name = $self->tablename("revision_ix2");
2937 $self->{dbh}->do("
2938 CREATE TABLE $tablename (
2939 name TEXT NOT NULL,
2940 revision INTEGER NOT NULL,
2941 filehash TEXT NOT NULL,
2942 commithash TEXT NOT NULL,
2943 author TEXT NOT NULL,
2944 modified TEXT NOT NULL,
2945 mode TEXT NOT NULL
2948 $self->{dbh}->do("
2949 CREATE INDEX $ix1name
2950 ON $tablename (name,revision)
2952 $self->{dbh}->do("
2953 CREATE INDEX $ix2name
2954 ON $tablename (name,commithash)
2958 # Construct the head table if required
2959 unless ( $self->{tables}{$self->tablename("head")} )
2961 my $tablename = $self->tablename("head");
2962 my $ix1name = $self->tablename("head_ix1");
2963 $self->{dbh}->do("
2964 CREATE TABLE $tablename (
2965 name TEXT NOT NULL,
2966 revision INTEGER NOT NULL,
2967 filehash TEXT NOT NULL,
2968 commithash TEXT NOT NULL,
2969 author TEXT NOT NULL,
2970 modified TEXT NOT NULL,
2971 mode TEXT NOT NULL
2974 $self->{dbh}->do("
2975 CREATE INDEX $ix1name
2976 ON $tablename (name)
2980 # Construct the properties table if required
2981 unless ( $self->{tables}{$self->tablename("properties")} )
2983 my $tablename = $self->tablename("properties");
2984 $self->{dbh}->do("
2985 CREATE TABLE $tablename (
2986 key TEXT NOT NULL PRIMARY KEY,
2987 value TEXT
2992 # Construct the commitmsgs table if required
2993 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2995 my $tablename = $self->tablename("commitmsgs");
2996 $self->{dbh}->do("
2997 CREATE TABLE $tablename (
2998 key TEXT NOT NULL PRIMARY KEY,
2999 value TEXT
3004 return $self;
3007 =head2 tablename
3009 =cut
3010 sub tablename
3012 my $self = shift;
3013 my $name = shift;
3015 if (exists $self->{valid_tables}{$name}) {
3016 return $self->{dbtablenameprefix} . $name;
3017 } else {
3018 return undef;
3022 =head2 update
3024 =cut
3025 sub update
3027 my $self = shift;
3029 # first lets get the commit list
3030 $ENV{GIT_DIR} = $self->{git_path};
3032 my $commitsha1 = `git rev-parse $self->{module}`;
3033 chomp $commitsha1;
3035 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3036 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3038 die("Invalid module '$self->{module}'");
3042 my $git_log;
3043 my $lastcommit = $self->_get_prop("last_commit");
3045 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3046 return 1;
3049 # Start exclusive lock here...
3050 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3052 # TODO: log processing is memory bound
3053 # if we can parse into a 2nd file that is in reverse order
3054 # we can probably do something really efficient
3055 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3057 if (defined $lastcommit) {
3058 push @git_log_params, "$lastcommit..$self->{module}";
3059 } else {
3060 push @git_log_params, $self->{module};
3062 # git-rev-list is the backend / plumbing version of git-log
3063 open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3065 my @commits;
3067 my %commit = ();
3069 while ( <GITLOG> )
3071 chomp;
3072 if (m/^commit\s+(.*)$/) {
3073 # on ^commit lines put the just seen commit in the stack
3074 # and prime things for the next one
3075 if (keys %commit) {
3076 my %copy = %commit;
3077 unshift @commits, \%copy;
3078 %commit = ();
3080 my @parents = split(m/\s+/, $1);
3081 $commit{hash} = shift @parents;
3082 $commit{parents} = \@parents;
3083 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3084 # on rfc822-like lines seen before we see any message,
3085 # lowercase the entry and put it in the hash as key-value
3086 $commit{lc($1)} = $2;
3087 } else {
3088 # message lines - skip initial empty line
3089 # and trim whitespace
3090 if (!exists($commit{message}) && m/^\s*$/) {
3091 # define it to mark the end of headers
3092 $commit{message} = '';
3093 next;
3095 s/^\s+//; s/\s+$//; # trim ws
3096 $commit{message} .= $_ . "\n";
3099 close GITLOG;
3101 unshift @commits, \%commit if ( keys %commit );
3103 # Now all the commits are in the @commits bucket
3104 # ordered by time DESC. for each commit that needs processing,
3105 # determine whether it's following the last head we've seen or if
3106 # it's on its own branch, grab a file list, and add whatever's changed
3107 # NOTE: $lastcommit refers to the last commit from previous run
3108 # $lastpicked is the last commit we picked in this run
3109 my $lastpicked;
3110 my $head = {};
3111 if (defined $lastcommit) {
3112 $lastpicked = $lastcommit;
3115 my $committotal = scalar(@commits);
3116 my $commitcount = 0;
3118 # Load the head table into $head (for cached lookups during the update process)
3119 foreach my $file ( @{$self->gethead()} )
3121 $head->{$file->{name}} = $file;
3124 foreach my $commit ( @commits )
3126 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3127 if (defined $lastpicked)
3129 if (!in_array($lastpicked, @{$commit->{parents}}))
3131 # skip, we'll see this delta
3132 # as part of a merge later
3133 # warn "skipping off-track $commit->{hash}\n";
3134 next;
3135 } elsif (@{$commit->{parents}} > 1) {
3136 # it is a merge commit, for each parent that is
3137 # not $lastpicked, see if we can get a log
3138 # from the merge-base to that parent to put it
3139 # in the message as a merge summary.
3140 my @parents = @{$commit->{parents}};
3141 foreach my $parent (@parents) {
3142 # git-merge-base can potentially (but rarely) throw
3143 # several candidate merge bases. let's assume
3144 # that the first one is the best one.
3145 if ($parent eq $lastpicked) {
3146 next;
3148 my $base = eval {
3149 safe_pipe_capture('git', 'merge-base',
3150 $lastpicked, $parent);
3152 # The two branches may not be related at all,
3153 # in which case merge base simply fails to find
3154 # any, but that's Ok.
3155 next if ($@);
3157 chomp $base;
3158 if ($base) {
3159 my @merged;
3160 # print "want to log between $base $parent \n";
3161 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3162 or die "Cannot call git-log: $!";
3163 my $mergedhash;
3164 while (<GITLOG>) {
3165 chomp;
3166 if (!defined $mergedhash) {
3167 if (m/^commit\s+(.+)$/) {
3168 $mergedhash = $1;
3169 } else {
3170 next;
3172 } else {
3173 # grab the first line that looks non-rfc822
3174 # aka has content after leading space
3175 if (m/^\s+(\S.*)$/) {
3176 my $title = $1;
3177 $title = substr($title,0,100); # truncate
3178 unshift @merged, "$mergedhash $title";
3179 undef $mergedhash;
3183 close GITLOG;
3184 if (@merged) {
3185 $commit->{mergemsg} = $commit->{message};
3186 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3187 foreach my $summary (@merged) {
3188 $commit->{mergemsg} .= "\t$summary\n";
3190 $commit->{mergemsg} .= "\n\n";
3191 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3198 # convert the date to CVS-happy format
3199 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3201 if ( defined ( $lastpicked ) )
3203 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3204 local ($/) = "\0";
3205 while ( <FILELIST> )
3207 chomp;
3208 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3210 die("Couldn't process git-diff-tree line : $_");
3212 my ($mode, $hash, $change) = ($1, $2, $3);
3213 my $name = <FILELIST>;
3214 chomp($name);
3216 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3218 my $git_perms = "";
3219 $git_perms .= "r" if ( $mode & 4 );
3220 $git_perms .= "w" if ( $mode & 2 );
3221 $git_perms .= "x" if ( $mode & 1 );
3222 $git_perms = "rw" if ( $git_perms eq "" );
3224 if ( $change eq "D" )
3226 #$log->debug("DELETE $name");
3227 $head->{$name} = {
3228 name => $name,
3229 revision => $head->{$name}{revision} + 1,
3230 filehash => "deleted",
3231 commithash => $commit->{hash},
3232 modified => $commit->{date},
3233 author => $commit->{author},
3234 mode => $git_perms,
3236 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3238 elsif ( $change eq "M" || $change eq "T" )
3240 #$log->debug("MODIFIED $name");
3241 $head->{$name} = {
3242 name => $name,
3243 revision => $head->{$name}{revision} + 1,
3244 filehash => $hash,
3245 commithash => $commit->{hash},
3246 modified => $commit->{date},
3247 author => $commit->{author},
3248 mode => $git_perms,
3250 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3252 elsif ( $change eq "A" )
3254 #$log->debug("ADDED $name");
3255 $head->{$name} = {
3256 name => $name,
3257 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3258 filehash => $hash,
3259 commithash => $commit->{hash},
3260 modified => $commit->{date},
3261 author => $commit->{author},
3262 mode => $git_perms,
3264 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3266 else
3268 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3269 die;
3272 close FILELIST;
3273 } else {
3274 # this is used to detect files removed from the repo
3275 my $seen_files = {};
3277 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3278 local $/ = "\0";
3279 while ( <FILELIST> )
3281 chomp;
3282 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3284 die("Couldn't process git-ls-tree line : $_");
3287 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3289 $seen_files->{$git_filename} = 1;
3291 my ( $oldhash, $oldrevision, $oldmode ) = (
3292 $head->{$git_filename}{filehash},
3293 $head->{$git_filename}{revision},
3294 $head->{$git_filename}{mode}
3297 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3299 $git_perms = "";
3300 $git_perms .= "r" if ( $1 & 4 );
3301 $git_perms .= "w" if ( $1 & 2 );
3302 $git_perms .= "x" if ( $1 & 1 );
3303 } else {
3304 $git_perms = "rw";
3307 # unless the file exists with the same hash, we need to update it ...
3308 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3310 my $newrevision = ( $oldrevision or 0 ) + 1;
3312 $head->{$git_filename} = {
3313 name => $git_filename,
3314 revision => $newrevision,
3315 filehash => $git_hash,
3316 commithash => $commit->{hash},
3317 modified => $commit->{date},
3318 author => $commit->{author},
3319 mode => $git_perms,
3323 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3326 close FILELIST;
3328 # Detect deleted files
3329 foreach my $file ( keys %$head )
3331 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3333 $head->{$file}{revision}++;
3334 $head->{$file}{filehash} = "deleted";
3335 $head->{$file}{commithash} = $commit->{hash};
3336 $head->{$file}{modified} = $commit->{date};
3337 $head->{$file}{author} = $commit->{author};
3339 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3342 # END : "Detect deleted files"
3346 if (exists $commit->{mergemsg})
3348 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3351 $lastpicked = $commit->{hash};
3353 $self->_set_prop("last_commit", $commit->{hash});
3356 $self->delete_head();
3357 foreach my $file ( keys %$head )
3359 $self->insert_head(
3360 $file,
3361 $head->{$file}{revision},
3362 $head->{$file}{filehash},
3363 $head->{$file}{commithash},
3364 $head->{$file}{modified},
3365 $head->{$file}{author},
3366 $head->{$file}{mode},
3369 # invalidate the gethead cache
3370 $self->{gethead_cache} = undef;
3373 # Ending exclusive lock here
3374 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3377 sub insert_rev
3379 my $self = shift;
3380 my $name = shift;
3381 my $revision = shift;
3382 my $filehash = shift;
3383 my $commithash = shift;
3384 my $modified = shift;
3385 my $author = shift;
3386 my $mode = shift;
3387 my $tablename = $self->tablename("revision");
3389 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3390 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3393 sub insert_mergelog
3395 my $self = shift;
3396 my $key = shift;
3397 my $value = shift;
3398 my $tablename = $self->tablename("commitmsgs");
3400 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3401 $insert_mergelog->execute($key, $value);
3404 sub delete_head
3406 my $self = shift;
3407 my $tablename = $self->tablename("head");
3409 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3410 $delete_head->execute();
3413 sub insert_head
3415 my $self = shift;
3416 my $name = shift;
3417 my $revision = shift;
3418 my $filehash = shift;
3419 my $commithash = shift;
3420 my $modified = shift;
3421 my $author = shift;
3422 my $mode = shift;
3423 my $tablename = $self->tablename("head");
3425 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3426 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3429 sub _headrev
3431 my $self = shift;
3432 my $filename = shift;
3433 my $tablename = $self->tablename("head");
3435 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3436 $db_query->execute($filename);
3437 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3439 return ( $hash, $revision, $mode );
3442 sub _get_prop
3444 my $self = shift;
3445 my $key = shift;
3446 my $tablename = $self->tablename("properties");
3448 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3449 $db_query->execute($key);
3450 my ( $value ) = $db_query->fetchrow_array;
3452 return $value;
3455 sub _set_prop
3457 my $self = shift;
3458 my $key = shift;
3459 my $value = shift;
3460 my $tablename = $self->tablename("properties");
3462 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3463 $db_query->execute($value, $key);
3465 unless ( $db_query->rows )
3467 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3468 $db_query->execute($key, $value);
3471 return $value;
3474 =head2 gethead
3476 =cut
3478 sub gethead
3480 my $self = shift;
3481 my $tablename = $self->tablename("head");
3483 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3485 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3486 $db_query->execute();
3488 my $tree = [];
3489 while ( my $file = $db_query->fetchrow_hashref )
3491 push @$tree, $file;
3494 $self->{gethead_cache} = $tree;
3496 return $tree;
3499 =head2 getlog
3501 =cut
3503 sub getlog
3505 my $self = shift;
3506 my $filename = shift;
3507 my $tablename = $self->tablename("revision");
3509 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3510 $db_query->execute($filename);
3512 my $tree = [];
3513 while ( my $file = $db_query->fetchrow_hashref )
3515 push @$tree, $file;
3518 return $tree;
3521 =head2 getmeta
3523 This function takes a filename (with path) argument and returns a hashref of
3524 metadata for that file.
3526 =cut
3528 sub getmeta
3530 my $self = shift;
3531 my $filename = shift;
3532 my $revision = shift;
3533 my $tablename_rev = $self->tablename("revision");
3534 my $tablename_head = $self->tablename("head");
3536 my $db_query;
3537 if ( defined($revision) and $revision =~ /^\d+$/ )
3539 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3540 $db_query->execute($filename, $revision);
3542 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3544 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3545 $db_query->execute($filename, $revision);
3546 } else {
3547 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3548 $db_query->execute($filename);
3551 return $db_query->fetchrow_hashref;
3554 =head2 commitmessage
3556 this function takes a commithash and returns the commit message for that commit
3558 =cut
3559 sub commitmessage
3561 my $self = shift;
3562 my $commithash = shift;
3563 my $tablename = $self->tablename("commitmsgs");
3565 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3567 my $db_query;
3568 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3569 $db_query->execute($commithash);
3571 my ( $message ) = $db_query->fetchrow_array;
3573 if ( defined ( $message ) )
3575 $message .= " " if ( $message =~ /\n$/ );
3576 return $message;
3579 my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3580 shift @lines while ( $lines[0] =~ /\S/ );
3581 $message = join("",@lines);
3582 $message .= " " if ( $message =~ /\n$/ );
3583 return $message;
3586 =head2 gethistory
3588 This function takes a filename (with path) argument and returns an arrayofarrays
3589 containing revision,filehash,commithash ordered by revision descending
3591 =cut
3592 sub gethistory
3594 my $self = shift;
3595 my $filename = shift;
3596 my $tablename = $self->tablename("revision");
3598 my $db_query;
3599 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3600 $db_query->execute($filename);
3602 return $db_query->fetchall_arrayref;
3605 =head2 gethistorydense
3607 This function takes a filename (with path) argument and returns an arrayofarrays
3608 containing revision,filehash,commithash ordered by revision descending.
3610 This version of gethistory skips deleted entries -- so it is useful for annotate.
3611 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3612 and other git tools that depend on it.
3614 =cut
3615 sub gethistorydense
3617 my $self = shift;
3618 my $filename = shift;
3619 my $tablename = $self->tablename("revision");
3621 my $db_query;
3622 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3623 $db_query->execute($filename);
3625 return $db_query->fetchall_arrayref;
3628 =head2 in_array()
3630 from Array::PAT - mimics the in_array() function
3631 found in PHP. Yuck but works for small arrays.
3633 =cut
3634 sub in_array
3636 my ($check, @array) = @_;
3637 my $retval = 0;
3638 foreach my $test (@array){
3639 if($check eq $test){
3640 $retval = 1;
3643 return $retval;
3646 =head2 safe_pipe_capture
3648 an alternative to `command` that allows input to be passed as an array
3649 to work around shell problems with weird characters in arguments
3651 =cut
3652 sub safe_pipe_capture {
3654 my @output;
3656 if (my $pid = open my $child, '-|') {
3657 @output = (<$child>);
3658 close $child or die join(' ',@_).": $! $?";
3659 } else {
3660 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3662 return wantarray ? @output : join('',@output);
3665 =head2 mangle_dirname
3667 create a string from a directory name that is suitable to use as
3668 part of a filename, mainly by converting all chars except \w.- to _
3670 =cut
3671 sub mangle_dirname {
3672 my $dirname = shift;
3673 return unless defined $dirname;
3675 $dirname =~ s/[^\w.-]/_/g;
3677 return $dirname;
3680 =head2 mangle_tablename
3682 create a string from a that is suitable to use as part of an SQL table
3683 name, mainly by converting all chars except \w to _
3685 =cut
3686 sub mangle_tablename {
3687 my $tablename = shift;
3688 return unless defined $tablename;
3690 $tablename =~ s/[^\w_]/_/g;
3692 return $tablename;