Merge branch 'wk/man-deny-current-branch-is-default-these-days' into maint
[git/jnareb-git.git] / git-cvsserver.perl
blobc5ebfa06365da82d68103300ad6e8c818ab37fb6
1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@laptop.org>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use 5.008;
19 use strict;
20 use warnings;
21 use bytes;
23 use Fcntl;
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
26 use File::Basename;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
32 my $cfg;
34 my $DATE_LIST = {
35 Jan => "01",
36 Feb => "02",
37 Mar => "03",
38 Apr => "04",
39 May => "05",
40 Jun => "06",
41 Jul => "07",
42 Aug => "08",
43 Sep => "09",
44 Oct => "10",
45 Nov => "11",
46 Dec => "12",
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50 $| = 1;
52 #### Definition and mappings of functions ####
54 # NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
55 # requests, this list is incomplete. It is missing many rarer/optional
56 # requests. Perhaps some clients require a claim of support for
57 # these specific requests for main functionality to work?
58 my $methods = {
59 'Root' => \&req_Root,
60 'Valid-responses' => \&req_Validresponses,
61 'valid-requests' => \&req_validrequests,
62 'Directory' => \&req_Directory,
63 'Entry' => \&req_Entry,
64 'Modified' => \&req_Modified,
65 'Unchanged' => \&req_Unchanged,
66 'Questionable' => \&req_Questionable,
67 'Argument' => \&req_Argument,
68 'Argumentx' => \&req_Argument,
69 'expand-modules' => \&req_expandmodules,
70 'add' => \&req_add,
71 'remove' => \&req_remove,
72 'co' => \&req_co,
73 'update' => \&req_update,
74 'ci' => \&req_ci,
75 'diff' => \&req_diff,
76 'log' => \&req_log,
77 'rlog' => \&req_log,
78 'tag' => \&req_CATCHALL,
79 'status' => \&req_status,
80 'admin' => \&req_CATCHALL,
81 'history' => \&req_CATCHALL,
82 'watchers' => \&req_EMPTY,
83 'editors' => \&req_EMPTY,
84 'noop' => \&req_EMPTY,
85 'annotate' => \&req_annotate,
86 'Global_option' => \&req_Globaloption,
89 ##############################################
92 # $state holds all the bits of information the clients sends us that could
93 # potentially be useful when it comes to actually _doing_ something.
94 my $state = { prependdir => '' };
96 # Work is for managing temporary working directory
97 my $work =
99 state => undef, # undef, 1 (empty), 2 (with stuff)
100 workDir => undef,
101 index => undef,
102 emptyDir => undef,
103 tmpDir => undef
106 $log->info("--------------- STARTING -----------------");
108 my $usage =
109 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
110 " --base-path <path> : Prepend to requested CVSROOT\n".
111 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
112 " --strict-paths : Don't allow recursing into subdirectories\n".
113 " --export-all : Don't check for gitcvs.enabled in config\n".
114 " --version, -V : Print version information and exit\n".
115 " -h, -H : Print usage information and exit\n".
116 "\n".
117 "<directory> ... is a list of allowed directories. If no directories\n".
118 "are given, all are allowed. This is an additional restriction, gitcvs\n".
119 "access still needs to be enabled by the gitcvs.enabled config option.\n".
120 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
122 my @opts = ( 'h|H', 'version|V',
123 'base-path=s', 'strict-paths', 'export-all' );
124 GetOptions( $state, @opts )
125 or die $usage;
127 if ($state->{version}) {
128 print "git-cvsserver version $VERSION\n";
129 exit;
131 if ($state->{help}) {
132 print $usage;
133 exit;
136 my $TEMP_DIR = tempdir( CLEANUP => 1 );
137 $log->debug("Temporary directory is '$TEMP_DIR'");
139 $state->{method} = 'ext';
140 if (@ARGV) {
141 if ($ARGV[0] eq 'pserver') {
142 $state->{method} = 'pserver';
143 shift @ARGV;
144 } elsif ($ARGV[0] eq 'server') {
145 shift @ARGV;
149 # everything else is a directory
150 $state->{allowed_roots} = [ @ARGV ];
152 # don't export the whole system unless the users requests it
153 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
154 die "--export-all can only be used together with an explicit whitelist\n";
157 # Environment handling for running under git-shell
158 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
159 if ($state->{'base-path'}) {
160 die "Cannot specify base path both ways.\n";
162 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
163 $state->{'base-path'} = $base_path;
164 $log->debug("Picked up base path '$base_path' from environment.\n");
166 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
167 if (@{$state->{allowed_roots}}) {
168 die "Cannot specify roots both ways: @ARGV\n";
170 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
171 $state->{allowed_roots} = [ $allowed_root ];
172 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
175 # if we are called with a pserver argument,
176 # deal with the authentication cat before entering the
177 # main loop
178 if ($state->{method} eq 'pserver') {
179 my $line = <STDIN>; chomp $line;
180 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
181 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
183 my $request = $1;
184 $line = <STDIN>; chomp $line;
185 unless (req_Root('root', $line)) { # reuse Root
186 print "E Invalid root $line \n";
187 exit 1;
189 $line = <STDIN>; chomp $line;
190 my $user = $line;
191 $line = <STDIN>; chomp $line;
192 my $password = $line;
194 if ($user eq 'anonymous') {
195 # "A" will be 1 byte, use length instead in case the
196 # encryption method ever changes (yeah, right!)
197 if (length($password) > 1 ) {
198 print "E Don't supply a password for the `anonymous' user\n";
199 print "I HATE YOU\n";
200 exit 1;
203 # Fall through to LOVE
204 } else {
205 # Trying to authenticate a user
206 if (not exists $cfg->{gitcvs}->{authdb}) {
207 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
208 print "I HATE YOU\n";
209 exit 1;
212 my $authdb = $cfg->{gitcvs}->{authdb};
214 unless (-e $authdb) {
215 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
216 print "I HATE YOU\n";
217 exit 1;
220 my $auth_ok;
221 open my $passwd, "<", $authdb or die $!;
222 while (<$passwd>) {
223 if (m{^\Q$user\E:(.*)}) {
224 if (crypt($user, descramble($password)) eq $1) {
225 $auth_ok = 1;
229 close $passwd;
231 unless ($auth_ok) {
232 print "I HATE YOU\n";
233 exit 1;
236 # Fall through to LOVE
239 # For checking whether the user is anonymous on commit
240 $state->{user} = $user;
242 $line = <STDIN>; chomp $line;
243 unless ($line eq "END $request REQUEST") {
244 die "E Do not understand $line -- expecting END $request REQUEST\n";
246 print "I LOVE YOU\n";
247 exit if $request eq 'VERIFICATION'; # cvs login
248 # and now back to our regular programme...
251 # Keep going until the client closes the connection
252 while (<STDIN>)
254 chomp;
256 # Check to see if we've seen this method, and call appropriate function.
257 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
259 # use the $methods hash to call the appropriate sub for this command
260 #$log->info("Method : $1");
261 &{$methods->{$1}}($1,$2);
262 } else {
263 # log fatal because we don't understand this function. If this happens
264 # we're fairly screwed because we don't know if the client is expecting
265 # a response. If it is, the client will hang, we'll hang, and the whole
266 # thing will be custard.
267 $log->fatal("Don't understand command $_\n");
268 die("Unknown command $_");
272 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
273 $log->info("--------------- FINISH -----------------");
275 chdir '/';
276 exit 0;
278 # Magic catchall method.
279 # This is the method that will handle all commands we haven't yet
280 # implemented. It simply sends a warning to the log file indicating a
281 # command that hasn't been implemented has been invoked.
282 sub req_CATCHALL
284 my ( $cmd, $data ) = @_;
285 $log->warn("Unhandled command : req_$cmd : $data");
288 # This method invariably succeeds with an empty response.
289 sub req_EMPTY
291 print "ok\n";
294 # Root pathname \n
295 # Response expected: no. Tell the server which CVSROOT to use. Note that
296 # pathname is a local directory and not a fully qualified CVSROOT variable.
297 # pathname must already exist; if creating a new root, use the init
298 # request, not Root. pathname does not include the hostname of the server,
299 # how to access the server, etc.; by the time the CVS protocol is in use,
300 # connection, authentication, etc., are already taken care of. The Root
301 # request must be sent only once, and it must be sent before any requests
302 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
303 sub req_Root
305 my ( $cmd, $data ) = @_;
306 $log->debug("req_Root : $data");
308 unless ($data =~ m#^/#) {
309 print "error 1 Root must be an absolute pathname\n";
310 return 0;
313 my $cvsroot = $state->{'base-path'} || '';
314 $cvsroot =~ s#/+$##;
315 $cvsroot .= $data;
317 if ($state->{CVSROOT}
318 && ($state->{CVSROOT} ne $cvsroot)) {
319 print "error 1 Conflicting roots specified\n";
320 return 0;
323 $state->{CVSROOT} = $cvsroot;
325 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
327 if (@{$state->{allowed_roots}}) {
328 my $allowed = 0;
329 foreach my $dir (@{$state->{allowed_roots}}) {
330 next unless $dir =~ m#^/#;
331 $dir =~ s#/+$##;
332 if ($state->{'strict-paths'}) {
333 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
334 $allowed = 1;
335 last;
337 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
338 $allowed = 1;
339 last;
343 unless ($allowed) {
344 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
345 print "E \n";
346 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
347 return 0;
351 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
352 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
353 print "E \n";
354 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
355 return 0;
358 my @gitvars = `git config -l`;
359 if ($?) {
360 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
361 print "E \n";
362 print "error 1 - problem executing git-config\n";
363 return 0;
365 foreach my $line ( @gitvars )
367 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
368 unless ($2) {
369 $cfg->{$1}{$3} = $4;
370 } else {
371 $cfg->{$1}{$2}{$3} = $4;
375 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
376 || $cfg->{gitcvs}{enabled});
377 unless ($state->{'export-all'} ||
378 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
379 print "E GITCVS emulation needs to be enabled on this repo\n";
380 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
381 print "E \n";
382 print "error 1 GITCVS emulation disabled\n";
383 return 0;
386 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
387 if ( $logfile )
389 $log->setfile($logfile);
390 } else {
391 $log->nofile();
394 return 1;
397 # Global_option option \n
398 # Response expected: no. Transmit one of the global options `-q', `-Q',
399 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
400 # variations (such as combining of options) are allowed. For graceful
401 # handling of valid-requests, it is probably better to make new global
402 # options separate requests, rather than trying to add them to this
403 # request.
404 sub req_Globaloption
406 my ( $cmd, $data ) = @_;
407 $log->debug("req_Globaloption : $data");
408 $state->{globaloptions}{$data} = 1;
411 # Valid-responses request-list \n
412 # Response expected: no. Tell the server what responses the client will
413 # accept. request-list is a space separated list of tokens.
414 sub req_Validresponses
416 my ( $cmd, $data ) = @_;
417 $log->debug("req_Validresponses : $data");
419 # TODO : re-enable this, currently it's not particularly useful
420 #$state->{validresponses} = [ split /\s+/, $data ];
423 # valid-requests \n
424 # Response expected: yes. Ask the server to send back a Valid-requests
425 # response.
426 sub req_validrequests
428 my ( $cmd, $data ) = @_;
430 $log->debug("req_validrequests");
432 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
433 $log->debug("SEND : ok");
435 print "Valid-requests " . join(" ",keys %$methods) . "\n";
436 print "ok\n";
439 # Directory local-directory \n
440 # Additional data: repository \n. Response expected: no. Tell the server
441 # what directory to use. The repository should be a directory name from a
442 # previous server response. Note that this both gives a default for Entry
443 # and Modified and also for ci and the other commands; normal usage is to
444 # send Directory for each directory in which there will be an Entry or
445 # Modified, and then a final Directory for the original directory, then the
446 # command. The local-directory is relative to the top level at which the
447 # command is occurring (i.e. the last Directory which is sent before the
448 # command); to indicate that top level, `.' should be sent for
449 # local-directory.
450 sub req_Directory
452 my ( $cmd, $data ) = @_;
454 my $repository = <STDIN>;
455 chomp $repository;
458 $state->{localdir} = $data;
459 $state->{repository} = $repository;
460 $state->{path} = $repository;
461 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
462 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
463 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
465 $state->{directory} = $state->{localdir};
466 $state->{directory} = "" if ( $state->{directory} eq "." );
467 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
469 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
471 $log->info("Setting prepend to '$state->{path}'");
472 $state->{prependdir} = $state->{path};
473 foreach my $entry ( keys %{$state->{entries}} )
475 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
476 delete $state->{entries}{$entry};
480 if ( defined ( $state->{prependdir} ) )
482 $log->debug("Prepending '$state->{prependdir}' to state|directory");
483 $state->{directory} = $state->{prependdir} . $state->{directory}
485 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
488 # Entry entry-line \n
489 # Response expected: no. Tell the server what version of a file is on the
490 # local machine. The name in entry-line is a name relative to the directory
491 # most recently specified with Directory. If the user is operating on only
492 # some files in a directory, Entry requests for only those files need be
493 # included. If an Entry request is sent without Modified, Is-modified, or
494 # Unchanged, it means the file is lost (does not exist in the working
495 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
496 # are sent for the same file, Entry must be sent first. For a given file,
497 # one can send Modified, Is-modified, or Unchanged, but not more than one
498 # of these three.
499 sub req_Entry
501 my ( $cmd, $data ) = @_;
503 #$log->debug("req_Entry : $data");
505 my @data = split(/\//, $data, -1);
507 $state->{entries}{$state->{directory}.$data[1]} = {
508 revision => $data[2],
509 conflict => $data[3],
510 options => $data[4],
511 tag_or_date => $data[5],
514 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
517 # Questionable filename \n
518 # Response expected: no. Additional data: no. Tell the server to check
519 # whether filename should be ignored, and if not, next time the server
520 # sends responses, send (in a M response) `?' followed by the directory and
521 # filename. filename must not contain `/'; it needs to be a file in the
522 # directory named by the most recent Directory request.
523 sub req_Questionable
525 my ( $cmd, $data ) = @_;
527 $log->debug("req_Questionable : $data");
528 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
531 # add \n
532 # Response expected: yes. Add a file or directory. This uses any previous
533 # Argument, Directory, Entry, or Modified requests, if they have been sent.
534 # The last Directory sent specifies the working directory at the time of
535 # the operation. To add a directory, send the directory to be added using
536 # Directory and Argument requests.
537 sub req_add
539 my ( $cmd, $data ) = @_;
541 argsplit("add");
543 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
544 $updater->update();
546 my $addcount = 0;
548 foreach my $filename ( @{$state->{args}} )
550 $filename = filecleanup($filename);
552 my $meta = $updater->getmeta($filename);
553 my $wrev = revparse($filename);
555 if ($wrev && $meta && ($wrev=~/^-/))
557 # previously removed file, add back
558 $log->info("added file $filename was previously removed, send $meta->{revision}");
560 print "MT +updated\n";
561 print "MT text U \n";
562 print "MT fname $filename\n";
563 print "MT newline\n";
564 print "MT -updated\n";
566 unless ( $state->{globaloptions}{-n} )
568 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
570 print "Created $dirpart\n";
571 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
573 # this is an "entries" line
574 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
575 $log->debug("/$filepart/$meta->{revision}//$kopts/");
576 print "/$filepart/$meta->{revision}//$kopts/\n";
577 # permissions
578 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
579 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
580 # transmit file
581 transmitfile($meta->{filehash});
584 next;
587 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
589 print "E cvs add: nothing known about `$filename'\n";
590 next;
592 # TODO : check we're not squashing an already existing file
593 if ( defined ( $state->{entries}{$filename}{revision} ) )
595 print "E cvs add: `$filename' has already been entered\n";
596 next;
599 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
601 print "E cvs add: scheduling file `$filename' for addition\n";
603 print "Checked-in $dirpart\n";
604 print "$filename\n";
605 my $kopts = kopts_from_path($filename,"file",
606 $state->{entries}{$filename}{modified_filename});
607 print "/$filepart/0//$kopts/\n";
609 my $requestedKopts = $state->{opt}{k};
610 if(defined($requestedKopts))
612 $requestedKopts = "-k$requestedKopts";
614 else
616 $requestedKopts = "";
618 if( $kopts ne $requestedKopts )
620 $log->warn("Ignoring requested -k='$requestedKopts'"
621 . " for '$filename'; detected -k='$kopts' instead");
622 #TODO: Also have option to send warning to user?
625 $addcount++;
628 if ( $addcount == 1 )
630 print "E cvs add: use `cvs commit' to add this file permanently\n";
632 elsif ( $addcount > 1 )
634 print "E cvs add: use `cvs commit' to add these files permanently\n";
637 print "ok\n";
640 # remove \n
641 # Response expected: yes. Remove a file. This uses any previous Argument,
642 # Directory, Entry, or Modified requests, if they have been sent. The last
643 # Directory sent specifies the working directory at the time of the
644 # operation. Note that this request does not actually do anything to the
645 # repository; the only effect of a successful remove request is to supply
646 # the client with a new entries line containing `-' to indicate a removed
647 # file. In fact, the client probably could perform this operation without
648 # contacting the server, although using remove may cause the server to
649 # perform a few more checks. The client sends a subsequent ci request to
650 # actually record the removal in the repository.
651 sub req_remove
653 my ( $cmd, $data ) = @_;
655 argsplit("remove");
657 # Grab a handle to the SQLite db and do any necessary updates
658 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
659 $updater->update();
661 #$log->debug("add state : " . Dumper($state));
663 my $rmcount = 0;
665 foreach my $filename ( @{$state->{args}} )
667 $filename = filecleanup($filename);
669 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
671 print "E cvs remove: file `$filename' still in working directory\n";
672 next;
675 my $meta = $updater->getmeta($filename);
676 my $wrev = revparse($filename);
678 unless ( defined ( $wrev ) )
680 print "E cvs remove: nothing known about `$filename'\n";
681 next;
684 if ( defined($wrev) and ($wrev=~/^-/) )
686 print "E cvs remove: file `$filename' already scheduled for removal\n";
687 next;
690 unless ( $wrev eq $meta->{revision} )
692 # TODO : not sure if the format of this message is quite correct.
693 print "E cvs remove: Up to date check failed for `$filename'\n";
694 next;
698 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
700 print "E cvs remove: scheduling `$filename' for removal\n";
702 print "Checked-in $dirpart\n";
703 print "$filename\n";
704 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
705 print "/$filepart/-$wrev//$kopts/\n";
707 $rmcount++;
710 if ( $rmcount == 1 )
712 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
714 elsif ( $rmcount > 1 )
716 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
719 print "ok\n";
722 # Modified filename \n
723 # Response expected: no. Additional data: mode, \n, file transmission. Send
724 # the server a copy of one locally modified file. filename is a file within
725 # the most recent directory sent with Directory; it must not contain `/'.
726 # If the user is operating on only some files in a directory, only those
727 # files need to be included. This can also be sent without Entry, if there
728 # is no entry for the file.
729 sub req_Modified
731 my ( $cmd, $data ) = @_;
733 my $mode = <STDIN>;
734 defined $mode
735 or (print "E end of file reading mode for $data\n"), return;
736 chomp $mode;
737 my $size = <STDIN>;
738 defined $size
739 or (print "E end of file reading size of $data\n"), return;
740 chomp $size;
742 # Grab config information
743 my $blocksize = 8192;
744 my $bytesleft = $size;
745 my $tmp;
747 # Get a filehandle/name to write it to
748 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
750 # Loop over file data writing out to temporary file.
751 while ( $bytesleft )
753 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
754 read STDIN, $tmp, $blocksize;
755 print $fh $tmp;
756 $bytesleft -= $blocksize;
759 close $fh
760 or (print "E failed to write temporary, $filename: $!\n"), return;
762 # Ensure we have something sensible for the file mode
763 if ( $mode =~ /u=(\w+)/ )
765 $mode = $1;
766 } else {
767 $mode = "rw";
770 # Save the file data in $state
771 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
772 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
773 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
774 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
776 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
779 # Unchanged filename \n
780 # Response expected: no. Tell the server that filename has not been
781 # modified in the checked out directory. The filename is a file within the
782 # most recent directory sent with Directory; it must not contain `/'.
783 sub req_Unchanged
785 my ( $cmd, $data ) = @_;
787 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
789 #$log->debug("req_Unchanged : $data");
792 # Argument text \n
793 # Response expected: no. Save argument for use in a subsequent command.
794 # Arguments accumulate until an argument-using command is given, at which
795 # point they are forgotten.
796 # Argumentx text \n
797 # Response expected: no. Append \n followed by text to the current argument
798 # being saved.
799 sub req_Argument
801 my ( $cmd, $data ) = @_;
803 # Argumentx means: append to last Argument (with a newline in front)
805 $log->debug("$cmd : $data");
807 if ( $cmd eq 'Argumentx') {
808 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
809 } else {
810 push @{$state->{arguments}}, $data;
814 # expand-modules \n
815 # Response expected: yes. Expand the modules which are specified in the
816 # arguments. Returns the data in Module-expansion responses. Note that the
817 # server can assume that this is checkout or export, not rtag or rdiff; the
818 # latter do not access the working directory and thus have no need to
819 # expand modules on the client side. Expand may not be the best word for
820 # what this request does. It does not necessarily tell you all the files
821 # contained in a module, for example. Basically it is a way of telling you
822 # which working directories the server needs to know about in order to
823 # handle a checkout of the specified modules. For example, suppose that the
824 # server has a module defined by
825 # aliasmodule -a 1dir
826 # That is, one can check out aliasmodule and it will take 1dir in the
827 # repository and check it out to 1dir in the working directory. Now suppose
828 # the client already has this module checked out and is planning on using
829 # the co request to update it. Without using expand-modules, the client
830 # would have two bad choices: it could either send information about all
831 # working directories under the current directory, which could be
832 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
833 # stands for 1dir, and neglect to send information for 1dir, which would
834 # lead to incorrect operation. With expand-modules, the client would first
835 # ask for the module to be expanded:
836 sub req_expandmodules
838 my ( $cmd, $data ) = @_;
840 argsplit();
842 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
844 unless ( ref $state->{arguments} eq "ARRAY" )
846 print "ok\n";
847 return;
850 foreach my $module ( @{$state->{arguments}} )
852 $log->debug("SEND : Module-expansion $module");
853 print "Module-expansion $module\n";
856 print "ok\n";
857 statecleanup();
860 # co \n
861 # Response expected: yes. Get files from the repository. This uses any
862 # previous Argument, Directory, Entry, or Modified requests, if they have
863 # been sent. Arguments to this command are module names; the client cannot
864 # know what directories they correspond to except by (1) just sending the
865 # co request, and then seeing what directory names the server sends back in
866 # its responses, and (2) the expand-modules request.
867 sub req_co
869 my ( $cmd, $data ) = @_;
871 argsplit("co");
873 # Provide list of modules, if -c was used.
874 if (exists $state->{opt}{c}) {
875 my $showref = `git show-ref --heads`;
876 for my $line (split '\n', $showref) {
877 if ( $line =~ m% refs/heads/(.*)$% ) {
878 print "M $1\t$1\n";
881 print "ok\n";
882 return 1;
885 my $module = $state->{args}[0];
886 $state->{module} = $module;
887 my $checkout_path = $module;
889 # use the user specified directory if we're given it
890 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
892 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
894 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
896 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
898 # Grab a handle to the SQLite db and do any necessary updates
899 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
900 $updater->update();
902 $checkout_path =~ s|/$||; # get rid of trailing slashes
904 # Eclipse seems to need the Clear-sticky command
905 # to prepare the 'Entries' file for the new directory.
906 print "Clear-sticky $checkout_path/\n";
907 print $state->{CVSROOT} . "/$module/\n";
908 print "Clear-static-directory $checkout_path/\n";
909 print $state->{CVSROOT} . "/$module/\n";
910 print "Clear-sticky $checkout_path/\n"; # yes, twice
911 print $state->{CVSROOT} . "/$module/\n";
912 print "Template $checkout_path/\n";
913 print $state->{CVSROOT} . "/$module/\n";
914 print "0\n";
916 # instruct the client that we're checking out to $checkout_path
917 print "E cvs checkout: Updating $checkout_path\n";
919 my %seendirs = ();
920 my $lastdir ='';
922 # recursive
923 sub prepdir {
924 my ($dir, $repodir, $remotedir, $seendirs) = @_;
925 my $parent = dirname($dir);
926 $dir =~ s|/+$||;
927 $repodir =~ s|/+$||;
928 $remotedir =~ s|/+$||;
929 $parent =~ s|/+$||;
930 $log->debug("announcedir $dir, $repodir, $remotedir" );
932 if ($parent eq '.' || $parent eq './') {
933 $parent = '';
935 # recurse to announce unseen parents first
936 if (length($parent) && !exists($seendirs->{$parent})) {
937 prepdir($parent, $repodir, $remotedir, $seendirs);
939 # Announce that we are going to modify at the parent level
940 if ($parent) {
941 print "E cvs checkout: Updating $remotedir/$parent\n";
942 } else {
943 print "E cvs checkout: Updating $remotedir\n";
945 print "Clear-sticky $remotedir/$parent/\n";
946 print "$repodir/$parent/\n";
948 print "Clear-static-directory $remotedir/$dir/\n";
949 print "$repodir/$dir/\n";
950 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
951 print "$repodir/$parent/\n";
952 print "Template $remotedir/$dir/\n";
953 print "$repodir/$dir/\n";
954 print "0\n";
956 $seendirs->{$dir} = 1;
959 foreach my $git ( @{$updater->gethead} )
961 # Don't want to check out deleted files
962 next if ( $git->{filehash} eq "deleted" );
964 my $fullName = $git->{name};
965 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
967 if (length($git->{dir}) && $git->{dir} ne './'
968 && $git->{dir} ne $lastdir ) {
969 unless (exists($seendirs{$git->{dir}})) {
970 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
971 $checkout_path, \%seendirs);
972 $lastdir = $git->{dir};
973 $seendirs{$git->{dir}} = 1;
975 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
978 # modification time of this file
979 print "Mod-time $git->{modified}\n";
981 # print some information to the client
982 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
984 print "M U $checkout_path/$git->{dir}$git->{name}\n";
985 } else {
986 print "M U $checkout_path/$git->{name}\n";
989 # instruct client we're sending a file to put in this path
990 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
992 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
994 # this is an "entries" line
995 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
996 print "/$git->{name}/$git->{revision}//$kopts/\n";
997 # permissions
998 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1000 # transmit file
1001 transmitfile($git->{filehash});
1004 print "ok\n";
1006 statecleanup();
1009 # update \n
1010 # Response expected: yes. Actually do a cvs update command. This uses any
1011 # previous Argument, Directory, Entry, or Modified requests, if they have
1012 # been sent. The last Directory sent specifies the working directory at the
1013 # time of the operation. The -I option is not used--files which the client
1014 # can decide whether to ignore are not mentioned and the client sends the
1015 # Questionable request for others.
1016 sub req_update
1018 my ( $cmd, $data ) = @_;
1020 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1022 argsplit("update");
1025 # It may just be a client exploring the available heads/modules
1026 # in that case, list them as top level directories and leave it
1027 # at that. Eclipse uses this technique to offer you a list of
1028 # projects (heads in this case) to checkout.
1030 if ($state->{module} eq '') {
1031 my $showref = `git show-ref --heads`;
1032 print "E cvs update: Updating .\n";
1033 for my $line (split '\n', $showref) {
1034 if ( $line =~ m% refs/heads/(.*)$% ) {
1035 print "E cvs update: New directory `$1'\n";
1038 print "ok\n";
1039 return 1;
1043 # Grab a handle to the SQLite db and do any necessary updates
1044 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1046 $updater->update();
1048 argsfromdir($updater);
1050 #$log->debug("update state : " . Dumper($state));
1052 my $last_dirname = "///";
1054 # foreach file specified on the command line ...
1055 foreach my $filename ( @{$state->{args}} )
1057 $filename = filecleanup($filename);
1059 $log->debug("Processing file $filename");
1061 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1063 my $cur_dirname = dirname($filename);
1064 if ( $cur_dirname ne $last_dirname )
1066 $last_dirname = $cur_dirname;
1067 if ( $cur_dirname eq "" )
1069 $cur_dirname = ".";
1071 print "E cvs update: Updating $cur_dirname\n";
1075 # if we have a -C we should pretend we never saw modified stuff
1076 if ( exists ( $state->{opt}{C} ) )
1078 delete $state->{entries}{$filename}{modified_hash};
1079 delete $state->{entries}{$filename}{modified_filename};
1080 $state->{entries}{$filename}{unchanged} = 1;
1083 my $meta;
1084 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^(1\.\d+)$/ )
1086 $meta = $updater->getmeta($filename, $1);
1087 } else {
1088 $meta = $updater->getmeta($filename);
1091 # If -p was given, "print" the contents of the requested revision.
1092 if ( exists ( $state->{opt}{p} ) ) {
1093 if ( defined ( $meta->{revision} ) ) {
1094 $log->info("Printing '$filename' revision " . $meta->{revision});
1096 transmitfile($meta->{filehash}, { print => 1 });
1099 next;
1102 if ( ! defined $meta )
1104 $meta = {
1105 name => $filename,
1106 revision => '0',
1107 filehash => 'added'
1111 my $oldmeta = $meta;
1113 my $wrev = revparse($filename);
1115 # If the working copy is an old revision, lets get that version too for comparison.
1116 if ( defined($wrev) and $wrev ne $meta->{revision} )
1118 $oldmeta = $updater->getmeta($filename, $wrev);
1121 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1123 # Files are up to date if the working copy and repo copy have the same revision,
1124 # and the working copy is unmodified _and_ the user hasn't specified -C
1125 next if ( defined ( $wrev )
1126 and defined($meta->{revision})
1127 and $wrev eq $meta->{revision}
1128 and $state->{entries}{$filename}{unchanged}
1129 and not exists ( $state->{opt}{C} ) );
1131 # If the working copy and repo copy have the same revision,
1132 # but the working copy is modified, tell the client it's modified
1133 if ( defined ( $wrev )
1134 and defined($meta->{revision})
1135 and $wrev eq $meta->{revision}
1136 and defined($state->{entries}{$filename}{modified_hash})
1137 and not exists ( $state->{opt}{C} ) )
1139 $log->info("Tell the client the file is modified");
1140 print "MT text M \n";
1141 print "MT fname $filename\n";
1142 print "MT newline\n";
1143 next;
1146 if ( $meta->{filehash} eq "deleted" )
1148 # TODO: If it has been modified in the sandbox, error out
1149 # with the appropriate message, rather than deleting a modified
1150 # file.
1152 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1154 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1156 print "E cvs update: `$filename' is no longer in the repository\n";
1157 # Don't want to actually _DO_ the update if -n specified
1158 unless ( $state->{globaloptions}{-n} ) {
1159 print "Removed $dirpart\n";
1160 print "$filepart\n";
1163 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1164 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1165 or $meta->{filehash} eq 'added' )
1167 # normal update, just send the new revision (either U=Update,
1168 # or A=Add, or R=Remove)
1169 if ( defined($wrev) && ($wrev=~/^-/) )
1171 $log->info("Tell the client the file is scheduled for removal");
1172 print "MT text R \n";
1173 print "MT fname $filename\n";
1174 print "MT newline\n";
1175 next;
1177 elsif ( (!defined($wrev) || $wrev eq '0') &&
1178 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
1180 $log->info("Tell the client the file is scheduled for addition");
1181 print "MT text A \n";
1182 print "MT fname $filename\n";
1183 print "MT newline\n";
1184 next;
1187 else {
1188 $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
1189 print "MT +updated\n";
1190 print "MT text U \n";
1191 print "MT fname $filename\n";
1192 print "MT newline\n";
1193 print "MT -updated\n";
1196 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1198 # Don't want to actually _DO_ the update if -n specified
1199 unless ( $state->{globaloptions}{-n} )
1201 if ( defined ( $wrev ) )
1203 # instruct client we're sending a file to put in this path as a replacement
1204 print "Update-existing $dirpart\n";
1205 $log->debug("Updating existing file 'Update-existing $dirpart'");
1206 } else {
1207 # instruct client we're sending a file to put in this path as a new file
1208 print "Clear-static-directory $dirpart\n";
1209 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1210 print "Clear-sticky $dirpart\n";
1211 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1213 $log->debug("Creating new file 'Created $dirpart'");
1214 print "Created $dirpart\n";
1216 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1218 # this is an "entries" line
1219 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1220 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1221 print "/$filepart/$meta->{revision}//$kopts/\n";
1223 # permissions
1224 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1225 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1227 # transmit file
1228 transmitfile($meta->{filehash});
1230 } else {
1231 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1233 my $mergeDir = setupTmpDir();
1235 my $file_local = $filepart . ".mine";
1236 my $mergedFile = "$mergeDir/$file_local";
1237 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1238 my $file_old = $filepart . "." . $oldmeta->{revision};
1239 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1240 my $file_new = $filepart . "." . $meta->{revision};
1241 transmitfile($meta->{filehash}, { targetfile => $file_new });
1243 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1244 $log->info("Merging $file_local, $file_old, $file_new");
1245 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1247 $log->debug("Temporary directory for merge is $mergeDir");
1249 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1250 $return >>= 8;
1252 cleanupTmpDir();
1254 if ( $return == 0 )
1256 $log->info("Merged successfully");
1257 print "M M $filename\n";
1258 $log->debug("Merged $dirpart");
1260 # Don't want to actually _DO_ the update if -n specified
1261 unless ( $state->{globaloptions}{-n} )
1263 print "Merged $dirpart\n";
1264 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1265 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1266 my $kopts = kopts_from_path("$dirpart/$filepart",
1267 "file",$mergedFile);
1268 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1269 print "/$filepart/$meta->{revision}//$kopts/\n";
1272 elsif ( $return == 1 )
1274 $log->info("Merged with conflicts");
1275 print "E cvs update: conflicts found in $filename\n";
1276 print "M C $filename\n";
1278 # Don't want to actually _DO_ the update if -n specified
1279 unless ( $state->{globaloptions}{-n} )
1281 print "Merged $dirpart\n";
1282 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1283 my $kopts = kopts_from_path("$dirpart/$filepart",
1284 "file",$mergedFile);
1285 print "/$filepart/$meta->{revision}/+/$kopts/\n";
1288 else
1290 $log->warn("Merge failed");
1291 next;
1294 # Don't want to actually _DO_ the update if -n specified
1295 unless ( $state->{globaloptions}{-n} )
1297 # permissions
1298 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1299 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1301 # transmit file, format is single integer on a line by itself (file
1302 # size) followed by the file contents
1303 # TODO : we should copy files in blocks
1304 my $data = `cat $mergedFile`;
1305 $log->debug("File size : " . length($data));
1306 print length($data) . "\n";
1307 print $data;
1313 print "ok\n";
1316 sub req_ci
1318 my ( $cmd, $data ) = @_;
1320 argsplit("ci");
1322 #$log->debug("State : " . Dumper($state));
1324 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1326 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1328 print "error 1 anonymous user cannot commit via pserver\n";
1329 cleanupWorkTree();
1330 exit;
1333 if ( -e $state->{CVSROOT} . "/index" )
1335 $log->warn("file 'index' already exists in the git repository");
1336 print "error 1 Index already exists in git repo\n";
1337 cleanupWorkTree();
1338 exit;
1341 # Grab a handle to the SQLite db and do any necessary updates
1342 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1343 $updater->update();
1345 # Remember where the head was at the beginning.
1346 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1347 chomp $parenthash;
1348 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1349 print "error 1 pserver cannot find the current HEAD of module";
1350 cleanupWorkTree();
1351 exit;
1354 setupWorkTree($parenthash);
1356 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1358 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1360 my @committedfiles = ();
1361 my %oldmeta;
1363 # foreach file specified on the command line ...
1364 foreach my $filename ( @{$state->{args}} )
1366 my $committedfile = $filename;
1367 $filename = filecleanup($filename);
1369 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1371 my $meta = $updater->getmeta($filename);
1372 $oldmeta{$filename} = $meta;
1374 my $wrev = revparse($filename);
1376 my ( $filepart, $dirpart ) = filenamesplit($filename);
1378 # do a checkout of the file if it is part of this tree
1379 if ($wrev) {
1380 system('git', 'checkout-index', '-f', '-u', $filename);
1381 unless ($? == 0) {
1382 die "Error running git-checkout-index -f -u $filename : $!";
1386 my $addflag = 0;
1387 my $rmflag = 0;
1388 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1389 $addflag = 1 unless ( -e $filename );
1391 # Do up to date checking
1392 unless ( $addflag or $wrev eq $meta->{revision} or
1393 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1395 # fail everything if an up to date check fails
1396 print "error 1 Up to date check failed for $filename\n";
1397 cleanupWorkTree();
1398 exit;
1401 push @committedfiles, $committedfile;
1402 $log->info("Committing $filename");
1404 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1406 unless ( $rmflag )
1408 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1409 rename $state->{entries}{$filename}{modified_filename},$filename;
1411 # Calculate modes to remove
1412 my $invmode = "";
1413 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1415 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1416 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1419 if ( $rmflag )
1421 $log->info("Removing file '$filename'");
1422 unlink($filename);
1423 system("git", "update-index", "--remove", $filename);
1425 elsif ( $addflag )
1427 $log->info("Adding file '$filename'");
1428 system("git", "update-index", "--add", $filename);
1429 } else {
1430 $log->info("UpdatingX2 file '$filename'");
1431 system("git", "update-index", $filename);
1435 unless ( scalar(@committedfiles) > 0 )
1437 print "E No files to commit\n";
1438 print "ok\n";
1439 cleanupWorkTree();
1440 return;
1443 my $treehash = `git write-tree`;
1444 chomp $treehash;
1446 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1448 # write our commit message out if we have one ...
1449 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1450 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1451 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1452 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1453 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1455 } else {
1456 print $msg_fh "\n\nvia git-CVS emulator\n";
1458 close $msg_fh;
1460 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1461 chomp($commithash);
1462 $log->info("Commit hash : $commithash");
1464 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1466 $log->warn("Commit failed (Invalid commit hash)");
1467 print "error 1 Commit failed (unknown reason)\n";
1468 cleanupWorkTree();
1469 exit;
1472 ### Emulate git-receive-pack by running hooks/update
1473 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1474 $parenthash, $commithash );
1475 if( -x $hook[0] ) {
1476 unless( system( @hook ) == 0 )
1478 $log->warn("Commit failed (update hook declined to update ref)");
1479 print "error 1 Commit failed (update hook declined)\n";
1480 cleanupWorkTree();
1481 exit;
1485 ### Update the ref
1486 if (system(qw(git update-ref -m), "cvsserver ci",
1487 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1488 $log->warn("update-ref for $state->{module} failed.");
1489 print "error 1 Cannot commit -- update first\n";
1490 cleanupWorkTree();
1491 exit;
1494 ### Emulate git-receive-pack by running hooks/post-receive
1495 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1496 if( -x $hook ) {
1497 open(my $pipe, "| $hook") || die "can't fork $!";
1499 local $SIG{PIPE} = sub { die 'pipe broke' };
1501 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1503 close $pipe || die "bad pipe: $! $?";
1506 $updater->update();
1508 ### Then hooks/post-update
1509 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1510 if (-x $hook) {
1511 system($hook, "refs/heads/$state->{module}");
1514 # foreach file specified on the command line ...
1515 foreach my $filename ( @committedfiles )
1517 $filename = filecleanup($filename);
1519 my $meta = $updater->getmeta($filename);
1520 unless (defined $meta->{revision}) {
1521 $meta->{revision} = "1.1";
1524 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1526 $log->debug("Checked-in $dirpart : $filename");
1528 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1529 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1531 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1532 print "Remove-entry $dirpart\n";
1533 print "$filename\n";
1534 } else {
1535 if ($meta->{revision} eq "1.1") {
1536 print "M initial revision: 1.1\n";
1537 } else {
1538 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1540 print "Checked-in $dirpart\n";
1541 print "$filename\n";
1542 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1543 print "/$filepart/$meta->{revision}//$kopts/\n";
1547 cleanupWorkTree();
1548 print "ok\n";
1551 sub req_status
1553 my ( $cmd, $data ) = @_;
1555 argsplit("status");
1557 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1558 #$log->debug("status state : " . Dumper($state));
1560 # Grab a handle to the SQLite db and do any necessary updates
1561 my $updater;
1562 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1563 $updater->update();
1565 # if no files were specified, we need to work out what files we should
1566 # be providing status on ...
1567 argsfromdir($updater);
1569 # foreach file specified on the command line ...
1570 foreach my $filename ( @{$state->{args}} )
1572 $filename = filecleanup($filename);
1574 if ( exists($state->{opt}{l}) &&
1575 index($filename, '/', length($state->{prependdir})) >= 0 )
1577 next;
1580 my $meta = $updater->getmeta($filename);
1581 my $oldmeta = $meta;
1583 my $wrev = revparse($filename);
1585 # If the working copy is an old revision, lets get that
1586 # version too for comparison.
1587 if ( defined($wrev) and $wrev ne $meta->{revision} )
1589 $oldmeta = $updater->getmeta($filename, $wrev);
1592 # TODO : All possible statuses aren't yet implemented
1593 my $status;
1594 # Files are up to date if the working copy and repo copy have
1595 # the same revision, and the working copy is unmodified
1596 if ( defined ( $wrev ) and defined($meta->{revision}) and
1597 $wrev eq $meta->{revision} and
1598 ( ( $state->{entries}{$filename}{unchanged} and
1599 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1600 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1601 ( defined($state->{entries}{$filename}{modified_hash}) and
1602 $state->{entries}{$filename}{modified_hash} eq
1603 $meta->{filehash} ) ) )
1605 $status = "Up-to-date"
1608 # Need checkout if the working copy has a different (usually
1609 # older) revision than the repo copy, and the working copy is
1610 # unmodified
1611 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1612 $meta->{revision} ne $wrev and
1613 ( $state->{entries}{$filename}{unchanged} or
1614 ( defined($state->{entries}{$filename}{modified_hash}) and
1615 $state->{entries}{$filename}{modified_hash} eq
1616 $oldmeta->{filehash} ) ) )
1618 $status ||= "Needs Checkout";
1621 # Need checkout if it exists in the repo but doesn't have a working
1622 # copy
1623 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1625 $status ||= "Needs Checkout";
1628 # Locally modified if working copy and repo copy have the
1629 # same revision but there are local changes
1630 if ( defined ( $wrev ) and defined($meta->{revision}) and
1631 $wrev eq $meta->{revision} and
1632 $state->{entries}{$filename}{modified_filename} )
1634 $status ||= "Locally Modified";
1637 # Needs Merge if working copy revision is different
1638 # (usually older) than repo copy and there are local changes
1639 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1640 $meta->{revision} ne $wrev and
1641 $state->{entries}{$filename}{modified_filename} )
1643 $status ||= "Needs Merge";
1646 if ( defined ( $state->{entries}{$filename}{revision} ) and
1647 not defined ( $meta->{revision} ) )
1649 $status ||= "Locally Added";
1651 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1652 $wrev eq "-$meta->{revision}" )
1654 $status ||= "Locally Removed";
1656 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1657 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1659 $status ||= "Unresolved Conflict";
1661 if ( 0 )
1663 $status ||= "File had conflicts on merge";
1666 $status ||= "Unknown";
1668 my ($filepart) = filenamesplit($filename);
1670 print "M =======" . ( "=" x 60 ) . "\n";
1671 print "M File: $filepart\tStatus: $status\n";
1672 if ( defined($state->{entries}{$filename}{revision}) )
1674 print "M Working revision:\t" .
1675 $state->{entries}{$filename}{revision} . "\n";
1676 } else {
1677 print "M Working revision:\tNo entry for $filename\n";
1679 if ( defined($meta->{revision}) )
1681 print "M Repository revision:\t" .
1682 $meta->{revision} .
1683 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1684 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
1685 my($tag)=($tagOrDate=~m/^T(.+)$/);
1686 if( !defined($tag) )
1688 $tag="(none)";
1690 print "M Sticky Tag:\t\t$tag\n";
1691 my($date)=($tagOrDate=~m/^D(.+)$/);
1692 if( !defined($date) )
1694 $date="(none)";
1696 print "M Sticky Date:\t\t$date\n";
1697 my($options)=$state->{entries}{$filename}{options};
1698 if( $options eq "" )
1700 $options="(none)";
1702 print "M Sticky Options:\t\t$options\n";
1703 } else {
1704 print "M Repository revision:\tNo revision control file\n";
1706 print "M\n";
1709 print "ok\n";
1712 sub req_diff
1714 my ( $cmd, $data ) = @_;
1716 argsplit("diff");
1718 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1719 #$log->debug("status state : " . Dumper($state));
1721 my ($revision1, $revision2);
1722 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1724 $revision1 = $state->{opt}{r}[0];
1725 $revision2 = $state->{opt}{r}[1];
1726 } else {
1727 $revision1 = $state->{opt}{r};
1730 $log->debug("Diffing revisions " .
1731 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1732 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1734 # Grab a handle to the SQLite db and do any necessary updates
1735 my $updater;
1736 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1737 $updater->update();
1739 # if no files were specified, we need to work out what files we should
1740 # be providing status on ...
1741 argsfromdir($updater);
1743 # foreach file specified on the command line ...
1744 foreach my $filename ( @{$state->{args}} )
1746 $filename = filecleanup($filename);
1748 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1750 my $wrev = revparse($filename);
1752 # We need _something_ to diff against
1753 next unless ( defined ( $wrev ) );
1755 # if we have a -r switch, use it
1756 if ( defined ( $revision1 ) )
1758 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1759 $meta1 = $updater->getmeta($filename, $revision1);
1760 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1762 print "E File $filename at revision $revision1 doesn't exist\n";
1763 next;
1765 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1767 # otherwise we just use the working copy revision
1768 else
1770 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1771 $meta1 = $updater->getmeta($filename, $wrev);
1772 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1775 # if we have a second -r switch, use it too
1776 if ( defined ( $revision2 ) )
1778 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1779 $meta2 = $updater->getmeta($filename, $revision2);
1781 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1783 print "E File $filename at revision $revision2 doesn't exist\n";
1784 next;
1787 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1789 # otherwise we just use the working copy
1790 else
1792 $file2 = $state->{entries}{$filename}{modified_filename};
1795 # if we have been given -r, and we don't have a $file2 yet, lets
1796 # get one
1797 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1799 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1800 $meta2 = $updater->getmeta($filename, $wrev);
1801 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1804 # We need to have retrieved something useful
1805 next unless ( defined ( $meta1 ) );
1807 # Files to date if the working copy and repo copy have the same
1808 # revision, and the working copy is unmodified
1809 if ( not defined ( $meta2 ) and $wrev eq $meta1->{revision} and
1810 ( ( $state->{entries}{$filename}{unchanged} and
1811 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1812 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1813 ( defined($state->{entries}{$filename}{modified_hash}) and
1814 $state->{entries}{$filename}{modified_hash} eq
1815 $meta1->{filehash} ) ) )
1817 next;
1820 # Apparently we only show diffs for locally modified files
1821 unless ( defined($meta2) or
1822 defined ( $state->{entries}{$filename}{modified_filename} ) )
1824 next;
1827 print "M Index: $filename\n";
1828 print "M =======" . ( "=" x 60 ) . "\n";
1829 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1830 if ( defined ( $meta1 ) )
1832 print "M retrieving revision $meta1->{revision}\n"
1834 if ( defined ( $meta2 ) )
1836 print "M retrieving revision $meta2->{revision}\n"
1838 print "M diff ";
1839 foreach my $opt ( keys %{$state->{opt}} )
1841 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1843 foreach my $value ( @{$state->{opt}{$opt}} )
1845 print "-$opt $value ";
1847 } else {
1848 print "-$opt ";
1849 if ( defined ( $state->{opt}{$opt} ) )
1851 print "$state->{opt}{$opt} "
1855 print "$filename\n";
1857 $log->info("Diffing $filename -r $meta1->{revision} -r " .
1858 ( $meta2->{revision} or "workingcopy" ));
1860 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1862 if ( exists $state->{opt}{u} )
1864 system("diff -u -L '$filename revision $meta1->{revision}'" .
1865 " -L '$filename " .
1866 ( defined($meta2->{revision}) ?
1867 "revision $meta2->{revision}" :
1868 "working copy" ) .
1869 "' $file1 $file2 > $filediff" );
1870 } else {
1871 system("diff $file1 $file2 > $filediff");
1874 while ( <$fh> )
1876 print "M $_";
1878 close $fh;
1881 print "ok\n";
1884 sub req_log
1886 my ( $cmd, $data ) = @_;
1888 argsplit("log");
1890 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1891 #$log->debug("log state : " . Dumper($state));
1893 my ( $revFilter );
1894 if ( defined ( $state->{opt}{r} ) )
1896 $revFilter = $state->{opt}{r};
1899 # Grab a handle to the SQLite db and do any necessary updates
1900 my $updater;
1901 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1902 $updater->update();
1904 # if no files were specified, we need to work out what files we
1905 # should be providing status on ...
1906 argsfromdir($updater);
1908 # foreach file specified on the command line ...
1909 foreach my $filename ( @{$state->{args}} )
1911 $filename = filecleanup($filename);
1913 my $headmeta = $updater->getmeta($filename);
1915 my ($revisions,$totalrevisions) = $updater->getlog($filename,
1916 $revFilter);
1918 next unless ( scalar(@$revisions) );
1920 print "M \n";
1921 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1922 print "M Working file: $filename\n";
1923 print "M head: $headmeta->{revision}\n";
1924 print "M branch:\n";
1925 print "M locks: strict\n";
1926 print "M access list:\n";
1927 print "M symbolic names:\n";
1928 print "M keyword substitution: kv\n";
1929 print "M total revisions: $totalrevisions;\tselected revisions: " .
1930 scalar(@$revisions) . "\n";
1931 print "M description:\n";
1933 foreach my $revision ( @$revisions )
1935 print "M ----------------------------\n";
1936 print "M revision $revision->{revision}\n";
1937 # reformat the date for log output
1938 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
1939 defined($DATE_LIST->{$2}) )
1941 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
1942 $3, $DATE_LIST->{$2}, $1, $4 );
1944 $revision->{author} = cvs_author($revision->{author});
1945 print "M date: $revision->{modified};" .
1946 " author: $revision->{author}; state: " .
1947 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
1948 "; lines: +2 -3\n";
1949 my $commitmessage;
1950 $commitmessage = $updater->commitmessage($revision->{commithash});
1951 $commitmessage =~ s/^/M /mg;
1952 print $commitmessage . "\n";
1954 print "M =======" . ( "=" x 70 ) . "\n";
1957 print "ok\n";
1960 sub req_annotate
1962 my ( $cmd, $data ) = @_;
1964 argsplit("annotate");
1966 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1967 #$log->debug("status state : " . Dumper($state));
1969 # Grab a handle to the SQLite db and do any necessary updates
1970 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1971 $updater->update();
1973 # if no files were specified, we need to work out what files we should be providing annotate on ...
1974 argsfromdir($updater);
1976 # we'll need a temporary checkout dir
1977 setupWorkTree();
1979 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1981 # foreach file specified on the command line ...
1982 foreach my $filename ( @{$state->{args}} )
1984 $filename = filecleanup($filename);
1986 my $meta = $updater->getmeta($filename);
1988 next unless ( $meta->{revision} );
1990 # get all the commits that this file was in
1991 # in dense format -- aka skip dead revisions
1992 my $revisions = $updater->gethistorydense($filename);
1993 my $lastseenin = $revisions->[0][2];
1995 # populate the temporary index based on the latest commit were we saw
1996 # the file -- but do it cheaply without checking out any files
1997 # TODO: if we got a revision from the client, use that instead
1998 # to look up the commithash in sqlite (still good to default to
1999 # the current head as we do now)
2000 system("git", "read-tree", $lastseenin);
2001 unless ($? == 0)
2003 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2004 return;
2006 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
2008 # do a checkout of the file
2009 system('git', 'checkout-index', '-f', '-u', $filename);
2010 unless ($? == 0) {
2011 print "E error running git-checkout-index -f -u $filename : $!\n";
2012 return;
2015 $log->info("Annotate $filename");
2017 # Prepare a file with the commits from the linearized
2018 # history that annotate should know about. This prevents
2019 # git-jsannotate telling us about commits we are hiding
2020 # from the client.
2022 my $a_hints = "$work->{workDir}/.annotate_hints";
2023 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2024 print "E failed to open '$a_hints' for writing: $!\n";
2025 return;
2027 for (my $i=0; $i < @$revisions; $i++)
2029 print ANNOTATEHINTS $revisions->[$i][2];
2030 if ($i+1 < @$revisions) { # have we got a parent?
2031 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2033 print ANNOTATEHINTS "\n";
2036 print ANNOTATEHINTS "\n";
2037 close ANNOTATEHINTS
2038 or (print "E failed to write $a_hints: $!\n"), return;
2040 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2041 if (!open(ANNOTATE, "-|", @cmd)) {
2042 print "E error invoking ". join(' ',@cmd) .": $!\n";
2043 return;
2045 my $metadata = {};
2046 print "E Annotations for $filename\n";
2047 print "E ***************\n";
2048 while ( <ANNOTATE> )
2050 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2052 my $commithash = $1;
2053 my $data = $2;
2054 unless ( defined ( $metadata->{$commithash} ) )
2056 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2057 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
2058 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2060 printf("M %-7s (%-8s %10s): %s\n",
2061 $metadata->{$commithash}{revision},
2062 $metadata->{$commithash}{author},
2063 $metadata->{$commithash}{modified},
2064 $data
2066 } else {
2067 $log->warn("Error in annotate output! LINE: $_");
2068 print "E Annotate error \n";
2069 next;
2072 close ANNOTATE;
2075 # done; get out of the tempdir
2076 cleanupWorkTree();
2078 print "ok\n";
2082 # This method takes the state->{arguments} array and produces two new arrays.
2083 # The first is $state->{args} which is everything before the '--' argument, and
2084 # the second is $state->{files} which is everything after it.
2085 sub argsplit
2087 $state->{args} = [];
2088 $state->{files} = [];
2089 $state->{opt} = {};
2091 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2093 my $type = shift;
2095 if ( defined($type) )
2097 my $opt = {};
2098 $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" );
2099 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2100 $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" );
2101 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2102 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2103 $opt = { k => 1, m => 1 } if ( $type eq "add" );
2104 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2105 $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" );
2108 while ( scalar ( @{$state->{arguments}} ) > 0 )
2110 my $arg = shift @{$state->{arguments}};
2112 next if ( $arg eq "--" );
2113 next unless ( $arg =~ /\S/ );
2115 # if the argument looks like a switch
2116 if ( $arg =~ /^-(\w)(.*)/ )
2118 # if it's a switch that takes an argument
2119 if ( $opt->{$1} )
2121 # If this switch has already been provided
2122 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2124 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2125 if ( length($2) > 0 )
2127 push @{$state->{opt}{$1}},$2;
2128 } else {
2129 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2131 } else {
2132 # if there's extra data in the arg, use that as the argument for the switch
2133 if ( length($2) > 0 )
2135 $state->{opt}{$1} = $2;
2136 } else {
2137 $state->{opt}{$1} = shift @{$state->{arguments}};
2140 } else {
2141 $state->{opt}{$1} = undef;
2144 else
2146 push @{$state->{args}}, $arg;
2150 else
2152 my $mode = 0;
2154 foreach my $value ( @{$state->{arguments}} )
2156 if ( $value eq "--" )
2158 $mode++;
2159 next;
2161 push @{$state->{args}}, $value if ( $mode == 0 );
2162 push @{$state->{files}}, $value if ( $mode == 1 );
2167 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2168 sub argsfromdir
2170 my $updater = shift;
2172 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2174 return if ( scalar ( @{$state->{args}} ) > 1 );
2176 my @gethead = @{$updater->gethead};
2178 # push added files
2179 foreach my $file (keys %{$state->{entries}}) {
2180 if ( exists $state->{entries}{$file}{revision} &&
2181 $state->{entries}{$file}{revision} eq '0' )
2183 push @gethead, { name => $file, filehash => 'added' };
2187 if ( scalar(@{$state->{args}}) == 1 )
2189 my $arg = $state->{args}[0];
2190 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2192 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2194 foreach my $file ( @gethead )
2196 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2197 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2198 push @{$state->{args}}, $file->{name};
2201 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2202 } else {
2203 $log->info("Only one arg specified, populating file list automatically");
2205 $state->{args} = [];
2207 foreach my $file ( @gethead )
2209 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2210 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2211 push @{$state->{args}}, $file->{name};
2216 # This method cleans up the $state variable after a command that uses arguments has run
2217 sub statecleanup
2219 $state->{files} = [];
2220 $state->{args} = [];
2221 $state->{arguments} = [];
2222 $state->{entries} = {};
2225 # Return working directory CVS revision "1.X" out
2226 # of the the working directory "entries" state, for the given filename.
2227 # This is prefixed with a dash if the file is scheduled for removal
2228 # when it is committed.
2229 sub revparse
2231 my $filename = shift;
2233 return $state->{entries}{$filename}{revision};
2236 # This method takes a file hash and does a CVS "file transfer". Its
2237 # exact behaviour depends on a second, optional hash table argument:
2238 # - If $options->{targetfile}, dump the contents to that file;
2239 # - If $options->{print}, use M/MT to transmit the contents one line
2240 # at a time;
2241 # - Otherwise, transmit the size of the file, followed by the file
2242 # contents.
2243 sub transmitfile
2245 my $filehash = shift;
2246 my $options = shift;
2248 if ( defined ( $filehash ) and $filehash eq "deleted" )
2250 $log->warn("filehash is 'deleted'");
2251 return;
2254 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2256 my $type = `git cat-file -t $filehash`;
2257 chomp $type;
2259 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2261 my $size = `git cat-file -s $filehash`;
2262 chomp $size;
2264 $log->debug("transmitfile($filehash) size=$size, type=$type");
2266 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2268 if ( defined ( $options->{targetfile} ) )
2270 my $targetfile = $options->{targetfile};
2271 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2272 print NEWFILE $_ while ( <$fh> );
2273 close NEWFILE or die("Failed to write '$targetfile': $!");
2274 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2275 while ( <$fh> ) {
2276 if( /\n\z/ ) {
2277 print 'M ', $_;
2278 } else {
2279 print 'MT text ', $_, "\n";
2282 } else {
2283 print "$size\n";
2284 print while ( <$fh> );
2286 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2287 } else {
2288 die("Couldn't execute git-cat-file");
2292 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2293 # refers to the directory portion and the file portion of the filename
2294 # respectively
2295 sub filenamesplit
2297 my $filename = shift;
2298 my $fixforlocaldir = shift;
2300 my ( $filepart, $dirpart ) = ( $filename, "." );
2301 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2302 $dirpart .= "/";
2304 if ( $fixforlocaldir )
2306 $dirpart =~ s/^$state->{prependdir}//;
2309 return ( $filepart, $dirpart );
2312 sub filecleanup
2314 my $filename = shift;
2316 return undef unless(defined($filename));
2317 if ( $filename =~ /^\// )
2319 print "E absolute filenames '$filename' not supported by server\n";
2320 return undef;
2323 $filename =~ s/^\.\///g;
2324 $filename = $state->{prependdir} . $filename;
2325 return $filename;
2328 sub validateGitDir
2330 if( !defined($state->{CVSROOT}) )
2332 print "error 1 CVSROOT not specified\n";
2333 cleanupWorkTree();
2334 exit;
2336 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2338 print "error 1 Internally inconsistent CVSROOT\n";
2339 cleanupWorkTree();
2340 exit;
2344 # Setup working directory in a work tree with the requested version
2345 # loaded in the index.
2346 sub setupWorkTree
2348 my ($ver) = @_;
2350 validateGitDir();
2352 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2353 defined($work->{tmpDir}) )
2355 $log->warn("Bad work tree state management");
2356 print "error 1 Internal setup multiple work trees without cleanup\n";
2357 cleanupWorkTree();
2358 exit;
2361 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2363 if( !defined($work->{index}) )
2365 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2368 chdir $work->{workDir} or
2369 die "Unable to chdir to $work->{workDir}\n";
2371 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2373 $ENV{GIT_WORK_TREE} = ".";
2374 $ENV{GIT_INDEX_FILE} = $work->{index};
2375 $work->{state} = 2;
2377 if($ver)
2379 system("git","read-tree",$ver);
2380 unless ($? == 0)
2382 $log->warn("Error running git-read-tree");
2383 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2386 # else # req_annotate reads tree for each file
2389 # Ensure current directory is in some kind of working directory,
2390 # with a recent version loaded in the index.
2391 sub ensureWorkTree
2393 if( defined($work->{tmpDir}) )
2395 $log->warn("Bad work tree state management [ensureWorkTree()]");
2396 print "error 1 Internal setup multiple dirs without cleanup\n";
2397 cleanupWorkTree();
2398 exit;
2400 if( $work->{state} )
2402 return;
2405 validateGitDir();
2407 if( !defined($work->{emptyDir}) )
2409 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2411 chdir $work->{emptyDir} or
2412 die "Unable to chdir to $work->{emptyDir}\n";
2414 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2415 chomp $ver;
2416 if ($ver !~ /^[0-9a-f]{40}$/)
2418 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2419 print "error 1 cannot find the current HEAD of module";
2420 cleanupWorkTree();
2421 exit;
2424 if( !defined($work->{index}) )
2426 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2429 $ENV{GIT_WORK_TREE} = ".";
2430 $ENV{GIT_INDEX_FILE} = $work->{index};
2431 $work->{state} = 1;
2433 system("git","read-tree",$ver);
2434 unless ($? == 0)
2436 die "Error running git-read-tree $ver $!\n";
2440 # Cleanup working directory that is not needed any longer.
2441 sub cleanupWorkTree
2443 if( ! $work->{state} )
2445 return;
2448 chdir "/" or die "Unable to chdir '/'\n";
2450 if( defined($work->{workDir}) )
2452 rmtree( $work->{workDir} );
2453 undef $work->{workDir};
2455 undef $work->{state};
2458 # Setup a temporary directory (not a working tree), typically for
2459 # merging dirty state as in req_update.
2460 sub setupTmpDir
2462 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2463 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2465 return $work->{tmpDir};
2468 # Clean up a previously setupTmpDir. Restore previous work tree if
2469 # appropriate.
2470 sub cleanupTmpDir
2472 if ( !defined($work->{tmpDir}) )
2474 $log->warn("cleanup tmpdir that has not been setup");
2475 die "Cleanup tmpDir that has not been setup\n";
2477 if( defined($work->{state}) )
2479 if( $work->{state} == 1 )
2481 chdir $work->{emptyDir} or
2482 die "Unable to chdir to $work->{emptyDir}\n";
2484 elsif( $work->{state} == 2 )
2486 chdir $work->{workDir} or
2487 die "Unable to chdir to $work->{emptyDir}\n";
2489 else
2491 $log->warn("Inconsistent work dir state");
2492 die "Inconsistent work dir state\n";
2495 else
2497 chdir "/" or die "Unable to chdir '/'\n";
2501 # Given a path, this function returns a string containing the kopts
2502 # that should go into that path's Entries line. For example, a binary
2503 # file should get -kb.
2504 sub kopts_from_path
2506 my ($path, $srcType, $name) = @_;
2508 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2509 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2511 my ($val) = check_attr( "text", $path );
2512 if ( $val eq "unspecified" )
2514 $val = check_attr( "crlf", $path );
2516 if ( $val eq "unset" )
2518 return "-kb"
2520 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2521 $val eq "set" || $val eq "input" )
2523 return "";
2525 else
2527 $log->info("Unrecognized check_attr crlf $path : $val");
2531 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2533 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2535 return "-kb";
2537 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2539 if( is_binary($srcType,$name) )
2541 $log->debug("... as binary");
2542 return "-kb";
2544 else
2546 $log->debug("... as text");
2550 # Return "" to give no special treatment to any path
2551 return "";
2554 sub check_attr
2556 my ($attr,$path) = @_;
2557 ensureWorkTree();
2558 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2560 my $val = <$fh>;
2561 close $fh;
2562 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2563 return $val;
2565 else
2567 return undef;
2571 # This should have the same heuristics as convert.c:is_binary() and related.
2572 # Note that the bare CR test is done by callers in convert.c.
2573 sub is_binary
2575 my ($srcType,$name) = @_;
2576 $log->debug("is_binary($srcType,$name)");
2578 # Minimize amount of interpreted code run in the inner per-character
2579 # loop for large files, by totalling each character value and
2580 # then analyzing the totals.
2581 my @counts;
2582 my $i;
2583 for($i=0;$i<256;$i++)
2585 $counts[$i]=0;
2588 my $fh = open_blob_or_die($srcType,$name);
2589 my $line;
2590 while( defined($line=<$fh>) )
2592 # Any '\0' and bare CR are considered binary.
2593 if( $line =~ /\0|(\r[^\n])/ )
2595 close($fh);
2596 return 1;
2599 # Count up each character in the line:
2600 my $len=length($line);
2601 for($i=0;$i<$len;$i++)
2603 $counts[ord(substr($line,$i,1))]++;
2606 close $fh;
2608 # Don't count CR and LF as either printable/nonprintable
2609 $counts[ord("\n")]=0;
2610 $counts[ord("\r")]=0;
2612 # Categorize individual character count into printable and nonprintable:
2613 my $printable=0;
2614 my $nonprintable=0;
2615 for($i=0;$i<256;$i++)
2617 if( $i < 32 &&
2618 $i != ord("\b") &&
2619 $i != ord("\t") &&
2620 $i != 033 && # ESC
2621 $i != 014 ) # FF
2623 $nonprintable+=$counts[$i];
2625 elsif( $i==127 ) # DEL
2627 $nonprintable+=$counts[$i];
2629 else
2631 $printable+=$counts[$i];
2635 return ($printable >> 7) < $nonprintable;
2638 # Returns open file handle. Possible invocations:
2639 # - open_blob_or_die("file",$filename);
2640 # - open_blob_or_die("sha1",$filehash);
2641 sub open_blob_or_die
2643 my ($srcType,$name) = @_;
2644 my ($fh);
2645 if( $srcType eq "file" )
2647 if( !open $fh,"<",$name )
2649 $log->warn("Unable to open file $name: $!");
2650 die "Unable to open file $name: $!\n";
2653 elsif( $srcType eq "sha1" )
2655 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2657 $log->warn("Need filehash");
2658 die "Need filehash\n";
2661 my $type = `git cat-file -t $name`;
2662 chomp $type;
2664 unless ( defined ( $type ) and $type eq "blob" )
2666 $log->warn("Invalid type '$type' for '$name'");
2667 die ( "Invalid type '$type' (expected 'blob')" )
2670 my $size = `git cat-file -s $name`;
2671 chomp $size;
2673 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2675 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2677 $log->warn("Unable to open sha1 $name");
2678 die "Unable to open sha1 $name\n";
2681 else
2683 $log->warn("Unknown type of blob source: $srcType");
2684 die "Unknown type of blob source: $srcType\n";
2686 return $fh;
2689 # Generate a CVS author name from Git author information, by taking the local
2690 # part of the email address and replacing characters not in the Portable
2691 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2692 # Login names are Unix login names, which should be restricted to this
2693 # character set.
2694 sub cvs_author
2696 my $author_line = shift;
2697 (my $author) = $author_line =~ /<([^@>]*)/;
2699 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2700 $author =~ s/^-/_/;
2702 $author;
2706 sub descramble
2708 # This table is from src/scramble.c in the CVS source
2709 my @SHIFTS = (
2710 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2711 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2712 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2713 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2714 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2715 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2716 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2717 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2718 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2719 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2720 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2721 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2722 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2723 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2724 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2725 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2727 my ($str) = @_;
2729 # This should never happen, the same password format (A) has been
2730 # used by CVS since the beginning of time
2732 my $fmt = substr($str, 0, 1);
2733 die "invalid password format `$fmt'" unless $fmt eq 'A';
2736 my @str = unpack "C*", substr($str, 1);
2737 my $ret = join '', map { chr $SHIFTS[$_] } @str;
2738 return $ret;
2742 package GITCVS::log;
2744 ####
2745 #### Copyright The Open University UK - 2006.
2746 ####
2747 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2748 #### Martin Langhoff <martin@laptop.org>
2749 ####
2750 ####
2752 use strict;
2753 use warnings;
2755 =head1 NAME
2757 GITCVS::log
2759 =head1 DESCRIPTION
2761 This module provides very crude logging with a similar interface to
2762 Log::Log4perl
2764 =head1 METHODS
2766 =cut
2768 =head2 new
2770 Creates a new log object, optionally you can specify a filename here to
2771 indicate the file to log to. If no log file is specified, you can specify one
2772 later with method setfile, or indicate you no longer want logging with method
2773 nofile.
2775 Until one of these methods is called, all log calls will buffer messages ready
2776 to write out.
2778 =cut
2779 sub new
2781 my $class = shift;
2782 my $filename = shift;
2784 my $self = {};
2786 bless $self, $class;
2788 if ( defined ( $filename ) )
2790 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2793 return $self;
2796 =head2 setfile
2798 This methods takes a filename, and attempts to open that file as the log file.
2799 If successful, all buffered data is written out to the file, and any further
2800 logging is written directly to the file.
2802 =cut
2803 sub setfile
2805 my $self = shift;
2806 my $filename = shift;
2808 if ( defined ( $filename ) )
2810 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2813 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2815 while ( my $line = shift @{$self->{buffer}} )
2817 print {$self->{fh}} $line;
2821 =head2 nofile
2823 This method indicates no logging is going to be used. It flushes any entries in
2824 the internal buffer, and sets a flag to ensure no further data is put there.
2826 =cut
2827 sub nofile
2829 my $self = shift;
2831 $self->{nolog} = 1;
2833 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2835 $self->{buffer} = [];
2838 =head2 _logopen
2840 Internal method. Returns true if the log file is open, false otherwise.
2842 =cut
2843 sub _logopen
2845 my $self = shift;
2847 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2848 return 0;
2851 =head2 debug info warn fatal
2853 These four methods are wrappers to _log. They provide the actual interface for
2854 logging data.
2856 =cut
2857 sub debug { my $self = shift; $self->_log("debug", @_); }
2858 sub info { my $self = shift; $self->_log("info" , @_); }
2859 sub warn { my $self = shift; $self->_log("warn" , @_); }
2860 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2862 =head2 _log
2864 This is an internal method called by the logging functions. It generates a
2865 timestamp and pushes the logged line either to file, or internal buffer.
2867 =cut
2868 sub _log
2870 my $self = shift;
2871 my $level = shift;
2873 return if ( $self->{nolog} );
2875 my @time = localtime;
2876 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2877 $time[5] + 1900,
2878 $time[4] + 1,
2879 $time[3],
2880 $time[2],
2881 $time[1],
2882 $time[0],
2883 uc $level,
2886 if ( $self->_logopen )
2888 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2889 } else {
2890 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2894 =head2 DESTROY
2896 This method simply closes the file handle if one is open
2898 =cut
2899 sub DESTROY
2901 my $self = shift;
2903 if ( $self->_logopen )
2905 close $self->{fh};
2909 package GITCVS::updater;
2911 ####
2912 #### Copyright The Open University UK - 2006.
2913 ####
2914 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2915 #### Martin Langhoff <martin@laptop.org>
2916 ####
2917 ####
2919 use strict;
2920 use warnings;
2921 use DBI;
2923 =head1 METHODS
2925 =cut
2927 =head2 new
2929 =cut
2930 sub new
2932 my $class = shift;
2933 my $config = shift;
2934 my $module = shift;
2935 my $log = shift;
2937 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2938 die "Need to specify a module" unless ( defined($module) );
2940 $class = ref($class) || $class;
2942 my $self = {};
2944 bless $self, $class;
2946 $self->{valid_tables} = {'revision' => 1,
2947 'revision_ix1' => 1,
2948 'revision_ix2' => 1,
2949 'head' => 1,
2950 'head_ix1' => 1,
2951 'properties' => 1,
2952 'commitmsgs' => 1};
2954 $self->{module} = $module;
2955 $self->{git_path} = $config . "/";
2957 $self->{log} = $log;
2959 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2961 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2962 $cfg->{gitcvs}{dbdriver} || "SQLite";
2963 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2964 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2965 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2966 $cfg->{gitcvs}{dbuser} || "";
2967 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2968 $cfg->{gitcvs}{dbpass} || "";
2969 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2970 $cfg->{gitcvs}{dbtablenameprefix} || "";
2971 my %mapping = ( m => $module,
2972 a => $state->{method},
2973 u => getlogin || getpwuid($<) || $<,
2974 G => $self->{git_path},
2975 g => mangle_dirname($self->{git_path}),
2977 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2978 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2979 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2980 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2982 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2983 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2984 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2985 $self->{dbuser},
2986 $self->{dbpass});
2987 die "Error connecting to database\n" unless defined $self->{dbh};
2989 $self->{tables} = {};
2990 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2992 $self->{tables}{$table} = 1;
2995 # Construct the revision table if required
2996 # The revision table stores an entry for each file, each time that file
2997 # changes.
2998 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
2999 # This is not sufficient to support "-r {commithash}" for any
3000 # files except files that were modified by that commit (also,
3001 # some places in the code ignore/effectively strip out -r in
3002 # some cases, before it gets passed to getmeta()).
3003 # The "filehash" field typically has a git blob hash, but can also
3004 # be set to "dead" to indicate that the given version of the file
3005 # should not exist in the sandbox.
3006 unless ( $self->{tables}{$self->tablename("revision")} )
3008 my $tablename = $self->tablename("revision");
3009 my $ix1name = $self->tablename("revision_ix1");
3010 my $ix2name = $self->tablename("revision_ix2");
3011 $self->{dbh}->do("
3012 CREATE TABLE $tablename (
3013 name TEXT NOT NULL,
3014 revision INTEGER NOT NULL,
3015 filehash TEXT NOT NULL,
3016 commithash TEXT NOT NULL,
3017 author TEXT NOT NULL,
3018 modified TEXT NOT NULL,
3019 mode TEXT NOT NULL
3022 $self->{dbh}->do("
3023 CREATE INDEX $ix1name
3024 ON $tablename (name,revision)
3026 $self->{dbh}->do("
3027 CREATE INDEX $ix2name
3028 ON $tablename (name,commithash)
3032 # Construct the head table if required
3033 # The head table (along with the "last_commit" entry in the property
3034 # table) is the persisted working state of the "sub update" subroutine.
3035 # All of it's data is read entirely first, and completely recreated
3036 # last, every time "sub update" runs.
3037 # This is also used by "sub getmeta" when it is asked for the latest
3038 # version of a file (as opposed to some specific version).
3039 # Another way of thinking about it is as a single slice out of
3040 # "revisions", giving just the most recent revision information for
3041 # each file.
3042 unless ( $self->{tables}{$self->tablename("head")} )
3044 my $tablename = $self->tablename("head");
3045 my $ix1name = $self->tablename("head_ix1");
3046 $self->{dbh}->do("
3047 CREATE TABLE $tablename (
3048 name TEXT NOT NULL,
3049 revision INTEGER NOT NULL,
3050 filehash TEXT NOT NULL,
3051 commithash TEXT NOT NULL,
3052 author TEXT NOT NULL,
3053 modified TEXT NOT NULL,
3054 mode TEXT NOT NULL
3057 $self->{dbh}->do("
3058 CREATE INDEX $ix1name
3059 ON $tablename (name)
3063 # Construct the properties table if required
3064 # - "last_commit" - Used by "sub update".
3065 unless ( $self->{tables}{$self->tablename("properties")} )
3067 my $tablename = $self->tablename("properties");
3068 $self->{dbh}->do("
3069 CREATE TABLE $tablename (
3070 key TEXT NOT NULL PRIMARY KEY,
3071 value TEXT
3076 # Construct the commitmsgs table if required
3077 # The commitmsgs table is only used for merge commits, since
3078 # "sub update" will only keep one branch of parents. Shortlogs
3079 # for ignored commits (i.e. not on the chosen branch) will be used
3080 # to construct a replacement "collapsed" merge commit message,
3081 # which will be stored in this table. See also "sub commitmessage".
3082 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3084 my $tablename = $self->tablename("commitmsgs");
3085 $self->{dbh}->do("
3086 CREATE TABLE $tablename (
3087 key TEXT NOT NULL PRIMARY KEY,
3088 value TEXT
3093 return $self;
3096 =head2 tablename
3098 =cut
3099 sub tablename
3101 my $self = shift;
3102 my $name = shift;
3104 if (exists $self->{valid_tables}{$name}) {
3105 return $self->{dbtablenameprefix} . $name;
3106 } else {
3107 return undef;
3111 =head2 update
3113 Bring the database up to date with the latest changes from
3114 the git repository.
3116 Internal working state is read out of the "head" table and the
3117 "last_commit" property, then it updates "revisions" based on that, and
3118 finally it writes the new internal state back to the "head" table
3119 so it can be used as a starting point the next time update is called.
3121 =cut
3122 sub update
3124 my $self = shift;
3126 # first lets get the commit list
3127 $ENV{GIT_DIR} = $self->{git_path};
3129 my $commitsha1 = `git rev-parse $self->{module}`;
3130 chomp $commitsha1;
3132 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3133 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3135 die("Invalid module '$self->{module}'");
3139 my $git_log;
3140 my $lastcommit = $self->_get_prop("last_commit");
3142 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3143 return 1;
3146 # Start exclusive lock here...
3147 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3149 # TODO: log processing is memory bound
3150 # if we can parse into a 2nd file that is in reverse order
3151 # we can probably do something really efficient
3152 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3154 if (defined $lastcommit) {
3155 push @git_log_params, "$lastcommit..$self->{module}";
3156 } else {
3157 push @git_log_params, $self->{module};
3159 # git-rev-list is the backend / plumbing version of git-log
3160 open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3162 my @commits;
3164 my %commit = ();
3166 while ( <GITLOG> )
3168 chomp;
3169 if (m/^commit\s+(.*)$/) {
3170 # on ^commit lines put the just seen commit in the stack
3171 # and prime things for the next one
3172 if (keys %commit) {
3173 my %copy = %commit;
3174 unshift @commits, \%copy;
3175 %commit = ();
3177 my @parents = split(m/\s+/, $1);
3178 $commit{hash} = shift @parents;
3179 $commit{parents} = \@parents;
3180 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3181 # on rfc822-like lines seen before we see any message,
3182 # lowercase the entry and put it in the hash as key-value
3183 $commit{lc($1)} = $2;
3184 } else {
3185 # message lines - skip initial empty line
3186 # and trim whitespace
3187 if (!exists($commit{message}) && m/^\s*$/) {
3188 # define it to mark the end of headers
3189 $commit{message} = '';
3190 next;
3192 s/^\s+//; s/\s+$//; # trim ws
3193 $commit{message} .= $_ . "\n";
3196 close GITLOG;
3198 unshift @commits, \%commit if ( keys %commit );
3200 # Now all the commits are in the @commits bucket
3201 # ordered by time DESC. for each commit that needs processing,
3202 # determine whether it's following the last head we've seen or if
3203 # it's on its own branch, grab a file list, and add whatever's changed
3204 # NOTE: $lastcommit refers to the last commit from previous run
3205 # $lastpicked is the last commit we picked in this run
3206 my $lastpicked;
3207 my $head = {};
3208 if (defined $lastcommit) {
3209 $lastpicked = $lastcommit;
3212 my $committotal = scalar(@commits);
3213 my $commitcount = 0;
3215 # Load the head table into $head (for cached lookups during the update process)
3216 foreach my $file ( @{$self->gethead(1)} )
3218 $head->{$file->{name}} = $file;
3221 foreach my $commit ( @commits )
3223 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3224 if (defined $lastpicked)
3226 if (!in_array($lastpicked, @{$commit->{parents}}))
3228 # skip, we'll see this delta
3229 # as part of a merge later
3230 # warn "skipping off-track $commit->{hash}\n";
3231 next;
3232 } elsif (@{$commit->{parents}} > 1) {
3233 # it is a merge commit, for each parent that is
3234 # not $lastpicked (not given a CVS revision number),
3235 # see if we can get a log
3236 # from the merge-base to that parent to put it
3237 # in the message as a merge summary.
3238 my @parents = @{$commit->{parents}};
3239 foreach my $parent (@parents) {
3240 if ($parent eq $lastpicked) {
3241 next;
3243 # git-merge-base can potentially (but rarely) throw
3244 # several candidate merge bases. let's assume
3245 # that the first one is the best one.
3246 my $base = eval {
3247 safe_pipe_capture('git', 'merge-base',
3248 $lastpicked, $parent);
3250 # The two branches may not be related at all,
3251 # in which case merge base simply fails to find
3252 # any, but that's Ok.
3253 next if ($@);
3255 chomp $base;
3256 if ($base) {
3257 my @merged;
3258 # print "want to log between $base $parent \n";
3259 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3260 or die "Cannot call git-log: $!";
3261 my $mergedhash;
3262 while (<GITLOG>) {
3263 chomp;
3264 if (!defined $mergedhash) {
3265 if (m/^commit\s+(.+)$/) {
3266 $mergedhash = $1;
3267 } else {
3268 next;
3270 } else {
3271 # grab the first line that looks non-rfc822
3272 # aka has content after leading space
3273 if (m/^\s+(\S.*)$/) {
3274 my $title = $1;
3275 $title = substr($title,0,100); # truncate
3276 unshift @merged, "$mergedhash $title";
3277 undef $mergedhash;
3281 close GITLOG;
3282 if (@merged) {
3283 $commit->{mergemsg} = $commit->{message};
3284 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3285 foreach my $summary (@merged) {
3286 $commit->{mergemsg} .= "\t$summary\n";
3288 $commit->{mergemsg} .= "\n\n";
3289 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3296 # convert the date to CVS-happy format
3297 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3299 if ( defined ( $lastpicked ) )
3301 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3302 local ($/) = "\0";
3303 while ( <FILELIST> )
3305 chomp;
3306 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3308 die("Couldn't process git-diff-tree line : $_");
3310 my ($mode, $hash, $change) = ($1, $2, $3);
3311 my $name = <FILELIST>;
3312 chomp($name);
3314 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3316 my $git_perms = "";
3317 $git_perms .= "r" if ( $mode & 4 );
3318 $git_perms .= "w" if ( $mode & 2 );
3319 $git_perms .= "x" if ( $mode & 1 );
3320 $git_perms = "rw" if ( $git_perms eq "" );
3322 if ( $change eq "D" )
3324 #$log->debug("DELETE $name");
3325 $head->{$name} = {
3326 name => $name,
3327 revision => $head->{$name}{revision} + 1,
3328 filehash => "deleted",
3329 commithash => $commit->{hash},
3330 modified => $commit->{date},
3331 author => $commit->{author},
3332 mode => $git_perms,
3334 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3336 elsif ( $change eq "M" || $change eq "T" )
3338 #$log->debug("MODIFIED $name");
3339 $head->{$name} = {
3340 name => $name,
3341 revision => $head->{$name}{revision} + 1,
3342 filehash => $hash,
3343 commithash => $commit->{hash},
3344 modified => $commit->{date},
3345 author => $commit->{author},
3346 mode => $git_perms,
3348 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3350 elsif ( $change eq "A" )
3352 #$log->debug("ADDED $name");
3353 $head->{$name} = {
3354 name => $name,
3355 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3356 filehash => $hash,
3357 commithash => $commit->{hash},
3358 modified => $commit->{date},
3359 author => $commit->{author},
3360 mode => $git_perms,
3362 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3364 else
3366 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3367 die;
3370 close FILELIST;
3371 } else {
3372 # this is used to detect files removed from the repo
3373 my $seen_files = {};
3375 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3376 local $/ = "\0";
3377 while ( <FILELIST> )
3379 chomp;
3380 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3382 die("Couldn't process git-ls-tree line : $_");
3385 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3387 $seen_files->{$git_filename} = 1;
3389 my ( $oldhash, $oldrevision, $oldmode ) = (
3390 $head->{$git_filename}{filehash},
3391 $head->{$git_filename}{revision},
3392 $head->{$git_filename}{mode}
3395 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3397 $git_perms = "";
3398 $git_perms .= "r" if ( $1 & 4 );
3399 $git_perms .= "w" if ( $1 & 2 );
3400 $git_perms .= "x" if ( $1 & 1 );
3401 } else {
3402 $git_perms = "rw";
3405 # unless the file exists with the same hash, we need to update it ...
3406 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3408 my $newrevision = ( $oldrevision or 0 ) + 1;
3410 $head->{$git_filename} = {
3411 name => $git_filename,
3412 revision => $newrevision,
3413 filehash => $git_hash,
3414 commithash => $commit->{hash},
3415 modified => $commit->{date},
3416 author => $commit->{author},
3417 mode => $git_perms,
3421 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3424 close FILELIST;
3426 # Detect deleted files
3427 foreach my $file ( keys %$head )
3429 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3431 $head->{$file}{revision}++;
3432 $head->{$file}{filehash} = "deleted";
3433 $head->{$file}{commithash} = $commit->{hash};
3434 $head->{$file}{modified} = $commit->{date};
3435 $head->{$file}{author} = $commit->{author};
3437 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3440 # END : "Detect deleted files"
3444 if (exists $commit->{mergemsg})
3446 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3449 $lastpicked = $commit->{hash};
3451 $self->_set_prop("last_commit", $commit->{hash});
3454 $self->delete_head();
3455 foreach my $file ( keys %$head )
3457 $self->insert_head(
3458 $file,
3459 $head->{$file}{revision},
3460 $head->{$file}{filehash},
3461 $head->{$file}{commithash},
3462 $head->{$file}{modified},
3463 $head->{$file}{author},
3464 $head->{$file}{mode},
3467 # invalidate the gethead cache
3468 $self->{gethead_cache} = undef;
3471 # Ending exclusive lock here
3472 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3475 sub insert_rev
3477 my $self = shift;
3478 my $name = shift;
3479 my $revision = shift;
3480 my $filehash = shift;
3481 my $commithash = shift;
3482 my $modified = shift;
3483 my $author = shift;
3484 my $mode = shift;
3485 my $tablename = $self->tablename("revision");
3487 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3488 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3491 sub insert_mergelog
3493 my $self = shift;
3494 my $key = shift;
3495 my $value = shift;
3496 my $tablename = $self->tablename("commitmsgs");
3498 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3499 $insert_mergelog->execute($key, $value);
3502 sub delete_head
3504 my $self = shift;
3505 my $tablename = $self->tablename("head");
3507 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3508 $delete_head->execute();
3511 sub insert_head
3513 my $self = shift;
3514 my $name = shift;
3515 my $revision = shift;
3516 my $filehash = shift;
3517 my $commithash = shift;
3518 my $modified = shift;
3519 my $author = shift;