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.
8 #### Copyright The Open University UK - 2006.
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@laptop.org>
14 #### Released under the GNU Public License, version 2.
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
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?
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,
71 'remove' => \&req_remove,
73 'update' => \&req_update,
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
99 state => undef, # undef, 1 (empty), 2 (with stuff)
106 $log->info("--------------- STARTING -----------------");
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".
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 )
127 if ($state->{version}) {
128 print "git-cvsserver version $VERSION\n";
131 if ($state->{help}) {
136 my $TEMP_DIR = tempdir( CLEANUP => 1 );
137 $log->debug("Temporary directory is '$TEMP_DIR'");
139 $state->{method} = 'ext';
141 if ($ARGV[0] eq 'pserver') {
142 $state->{method} = 'pserver';
144 } elsif ($ARGV[0] eq 'server') {
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
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";
184 $line = <STDIN>; chomp $line;
185 unless (req_Root('root', $line)) { # reuse Root
186 print "E Invalid root $line \n";
189 $line = <STDIN>; chomp $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";
203 # Fall through to LOVE
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";
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";
221 open my $passwd, "<", $authdb or die $!;
223 if (m{^\Q$user\E:(.*)}) {
224 if (crypt($user, descramble($password)) eq $1) {
232 print "I HATE YOU\n";
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
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);
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 -----------------");
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.
284 my ( $cmd, $data ) = @_;
285 $log->warn("Unhandled command : req_$cmd : $data");
288 # This method invariably succeeds with an empty response.
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.
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";
313 my $cvsroot = $state->{'base-path'} || '';
317 if ($state->{CVSROOT}
318 && ($state->{CVSROOT} ne $cvsroot)) {
319 print "error 1 Conflicting roots specified\n";
323 $state->{CVSROOT} = $cvsroot;
325 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
327 if (@{$state->{allowed_roots}}) {
329 foreach my $dir (@{$state->{allowed_roots}}) {
330 next unless $dir =~ m#^/#;
332 if ($state->{'strict-paths'}) {
333 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
337 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
344 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
346 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
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";
354 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
358 my @gitvars = `git config -l`;
360 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
362 print "error 1 - problem executing git-config\n";
365 foreach my $line ( @gitvars )
367 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
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";
382 print "error 1 GITCVS emulation disabled\n";
386 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
389 $log->setfile($logfile);
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
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 ];
424 # Response expected: yes. Ask the server to send back a Valid-requests
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";
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
452 my ( $cmd, $data ) = @_;
454 my $repository = <STDIN>;
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
501 my ( $cmd, $data ) = @_;
503 #$log->debug("req_Entry : $data");
505 my @data = split(/\//, $data);
507 $state->{entries}{$state->{directory}.$data[1]} = {
508 revision => $data[2],
509 conflict => $data[3],
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.
525 my ( $cmd, $data ) = @_;
527 $log->debug("req_Questionable : $data");
528 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
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.
539 my ( $cmd, $data ) = @_;
543 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
546 argsfromdir($updater);
550 foreach my $filename ( @{$state->{args}} )
552 $filename = filecleanup($filename);
554 my $meta = $updater->getmeta($filename);
555 my $wrev = revparse($filename);
557 if ($wrev && $meta && ($wrev=~/^-/))
559 # previously removed file, add back
560 $log->info("added file $filename was previously removed, send $meta->{revision}");
562 print "MT +updated\n";
563 print "MT text U \n";
564 print "MT fname $filename\n";
565 print "MT newline\n";
566 print "MT -updated\n";
568 unless ( $state->{globaloptions}{-n} )
570 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
572 print "Created $dirpart\n";
573 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
575 # this is an "entries" line
576 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
577 $log->debug("/$filepart/$meta->{revision}//$kopts/");
578 print "/$filepart/$meta->{revision}//$kopts/\n";
580 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
581 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
583 transmitfile($meta->{filehash});
589 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
591 print "E cvs add: nothing known about `$filename'\n";
594 # TODO : check we're not squashing an already existing file
595 if ( defined ( $state->{entries}{$filename}{revision} ) )
597 print "E cvs add: `$filename' has already been entered\n";
601 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
603 print "E cvs add: scheduling file `$filename' for addition\n";
605 print "Checked-in $dirpart\n";
607 my $kopts = kopts_from_path($filename,"file",
608 $state->{entries}{$filename}{modified_filename});
609 print "/$filepart/0//$kopts/\n";
611 my $requestedKopts = $state->{opt}{k};
612 if(defined($requestedKopts))
614 $requestedKopts = "-k$requestedKopts";
618 $requestedKopts = "";
620 if( $kopts ne $requestedKopts )
622 $log->warn("Ignoring requested -k='$requestedKopts'"
623 . " for '$filename'; detected -k='$kopts' instead");
624 #TODO: Also have option to send warning to user?
630 if ( $addcount == 1 )
632 print "E cvs add: use `cvs commit' to add this file permanently\n";
634 elsif ( $addcount > 1 )
636 print "E cvs add: use `cvs commit' to add these files permanently\n";
643 # Response expected: yes. Remove a file. This uses any previous Argument,
644 # Directory, Entry, or Modified requests, if they have been sent. The last
645 # Directory sent specifies the working directory at the time of the
646 # operation. Note that this request does not actually do anything to the
647 # repository; the only effect of a successful remove request is to supply
648 # the client with a new entries line containing `-' to indicate a removed
649 # file. In fact, the client probably could perform this operation without
650 # contacting the server, although using remove may cause the server to
651 # perform a few more checks. The client sends a subsequent ci request to
652 # actually record the removal in the repository.
655 my ( $cmd, $data ) = @_;
659 # Grab a handle to the SQLite db and do any necessary updates
660 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
663 #$log->debug("add state : " . Dumper($state));
667 foreach my $filename ( @{$state->{args}} )
669 $filename = filecleanup($filename);
671 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
673 print "E cvs remove: file `$filename' still in working directory\n";
677 my $meta = $updater->getmeta($filename);
678 my $wrev = revparse($filename);
680 unless ( defined ( $wrev ) )
682 print "E cvs remove: nothing known about `$filename'\n";
686 if ( defined($wrev) and ($wrev=~/^-/) )
688 print "E cvs remove: file `$filename' already scheduled for removal\n";
692 unless ( $wrev eq $meta->{revision} )
694 # TODO : not sure if the format of this message is quite correct.
695 print "E cvs remove: Up to date check failed for `$filename'\n";
700 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
702 print "E cvs remove: scheduling `$filename' for removal\n";
704 print "Checked-in $dirpart\n";
706 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
707 print "/$filepart/-$wrev//$kopts/\n";
714 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
716 elsif ( $rmcount > 1 )
718 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
724 # Modified filename \n
725 # Response expected: no. Additional data: mode, \n, file transmission. Send
726 # the server a copy of one locally modified file. filename is a file within
727 # the most recent directory sent with Directory; it must not contain `/'.
728 # If the user is operating on only some files in a directory, only those
729 # files need to be included. This can also be sent without Entry, if there
730 # is no entry for the file.
733 my ( $cmd, $data ) = @_;
737 or (print "E end of file reading mode for $data\n"), return;
741 or (print "E end of file reading size of $data\n"), return;
744 # Grab config information
745 my $blocksize = 8192;
746 my $bytesleft = $size;
749 # Get a filehandle/name to write it to
750 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
752 # Loop over file data writing out to temporary file.
755 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
756 read STDIN, $tmp, $blocksize;
758 $bytesleft -= $blocksize;
762 or (print "E failed to write temporary, $filename: $!\n"), return;
764 # Ensure we have something sensible for the file mode
765 if ( $mode =~ /u=(\w+)/ )
772 # Save the file data in $state
773 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
774 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
775 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
776 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
778 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
781 # Unchanged filename \n
782 # Response expected: no. Tell the server that filename has not been
783 # modified in the checked out directory. The filename is a file within the
784 # most recent directory sent with Directory; it must not contain `/'.
787 my ( $cmd, $data ) = @_;
789 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
791 #$log->debug("req_Unchanged : $data");
795 # Response expected: no. Save argument for use in a subsequent command.
796 # Arguments accumulate until an argument-using command is given, at which
797 # point they are forgotten.
799 # Response expected: no. Append \n followed by text to the current argument
803 my ( $cmd, $data ) = @_;
805 # Argumentx means: append to last Argument (with a newline in front)
807 $log->debug("$cmd : $data");
809 if ( $cmd eq 'Argumentx') {
810 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
812 push @{$state->{arguments}}, $data;
817 # Response expected: yes. Expand the modules which are specified in the
818 # arguments. Returns the data in Module-expansion responses. Note that the
819 # server can assume that this is checkout or export, not rtag or rdiff; the
820 # latter do not access the working directory and thus have no need to
821 # expand modules on the client side. Expand may not be the best word for
822 # what this request does. It does not necessarily tell you all the files
823 # contained in a module, for example. Basically it is a way of telling you
824 # which working directories the server needs to know about in order to
825 # handle a checkout of the specified modules. For example, suppose that the
826 # server has a module defined by
827 # aliasmodule -a 1dir
828 # That is, one can check out aliasmodule and it will take 1dir in the
829 # repository and check it out to 1dir in the working directory. Now suppose
830 # the client already has this module checked out and is planning on using
831 # the co request to update it. Without using expand-modules, the client
832 # would have two bad choices: it could either send information about all
833 # working directories under the current directory, which could be
834 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
835 # stands for 1dir, and neglect to send information for 1dir, which would
836 # lead to incorrect operation. With expand-modules, the client would first
837 # ask for the module to be expanded:
838 sub req_expandmodules
840 my ( $cmd, $data ) = @_;
844 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
846 unless ( ref $state->{arguments} eq "ARRAY" )
852 foreach my $module ( @{$state->{arguments}} )
854 $log->debug("SEND : Module-expansion $module");
855 print "Module-expansion $module\n";
863 # Response expected: yes. Get files from the repository. This uses any
864 # previous Argument, Directory, Entry, or Modified requests, if they have
865 # been sent. Arguments to this command are module names; the client cannot
866 # know what directories they correspond to except by (1) just sending the
867 # co request, and then seeing what directory names the server sends back in
868 # its responses, and (2) the expand-modules request.
871 my ( $cmd, $data ) = @_;
875 # Provide list of modules, if -c was used.
876 if (exists $state->{opt}{c}) {
877 my $showref = `git show-ref --heads`;
878 for my $line (split '\n', $showref) {
879 if ( $line =~ m% refs/heads/(.*)$% ) {
887 my $module = $state->{args}[0];
888 $state->{module} = $module;
889 my $checkout_path = $module;
891 # use the user specified directory if we're given it
892 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
894 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
896 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
898 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
900 # Grab a handle to the SQLite db and do any necessary updates
901 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
904 $checkout_path =~ s|/$||; # get rid of trailing slashes
906 # Eclipse seems to need the Clear-sticky command
907 # to prepare the 'Entries' file for the new directory.
908 print "Clear-sticky $checkout_path/\n";
909 print $state->{CVSROOT} . "/$module/\n";
910 print "Clear-static-directory $checkout_path/\n";
911 print $state->{CVSROOT} . "/$module/\n";
912 print "Clear-sticky $checkout_path/\n"; # yes, twice
913 print $state->{CVSROOT} . "/$module/\n";
914 print "Template $checkout_path/\n";
915 print $state->{CVSROOT} . "/$module/\n";
918 # instruct the client that we're checking out to $checkout_path
919 print "E cvs checkout: Updating $checkout_path\n";
926 my ($dir, $repodir, $remotedir, $seendirs) = @_;
927 my $parent = dirname($dir);
930 $remotedir =~ s|/+$||;
932 $log->debug("announcedir $dir, $repodir, $remotedir" );
934 if ($parent eq '.' || $parent eq './') {
937 # recurse to announce unseen parents first
938 if (length($parent) && !exists($seendirs->{$parent})) {
939 prepdir($parent, $repodir, $remotedir, $seendirs);
941 # Announce that we are going to modify at the parent level
943 print "E cvs checkout: Updating $remotedir/$parent\n";
945 print "E cvs checkout: Updating $remotedir\n";
947 print "Clear-sticky $remotedir/$parent/\n";
948 print "$repodir/$parent/\n";
950 print "Clear-static-directory $remotedir/$dir/\n";
951 print "$repodir/$dir/\n";
952 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
953 print "$repodir/$parent/\n";
954 print "Template $remotedir/$dir/\n";
955 print "$repodir/$dir/\n";
958 $seendirs->{$dir} = 1;
961 foreach my $git ( @{$updater->gethead} )
963 # Don't want to check out deleted files
964 next if ( $git->{filehash} eq "deleted" );
966 my $fullName = $git->{name};
967 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
969 if (length($git->{dir}) && $git->{dir} ne './'
970 && $git->{dir} ne $lastdir ) {
971 unless (exists($seendirs{$git->{dir}})) {
972 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
973 $checkout_path, \%seendirs);
974 $lastdir = $git->{dir};
975 $seendirs{$git->{dir}} = 1;
977 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
980 # modification time of this file
981 print "Mod-time $git->{modified}\n";
983 # print some information to the client
984 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
986 print "M U $checkout_path/$git->{dir}$git->{name}\n";
988 print "M U $checkout_path/$git->{name}\n";
991 # instruct client we're sending a file to put in this path
992 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
994 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
996 # this is an "entries" line
997 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
998 print "/$git->{name}/$git->{revision}//$kopts/\n";
1000 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1003 transmitfile($git->{filehash});
1012 # Response expected: yes. Actually do a cvs update command. This uses any
1013 # previous Argument, Directory, Entry, or Modified requests, if they have
1014 # been sent. The last Directory sent specifies the working directory at the
1015 # time of the operation. The -I option is not used--files which the client
1016 # can decide whether to ignore are not mentioned and the client sends the
1017 # Questionable request for others.
1020 my ( $cmd, $data ) = @_;
1022 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1027 # It may just be a client exploring the available heads/modules
1028 # in that case, list them as top level directories and leave it
1029 # at that. Eclipse uses this technique to offer you a list of
1030 # projects (heads in this case) to checkout.
1032 if ($state->{module} eq '') {
1033 my $showref = `git show-ref --heads`;
1034 print "E cvs update: Updating .\n";
1035 for my $line (split '\n', $showref) {
1036 if ( $line =~ m% refs/heads/(.*)$% ) {
1037 print "E cvs update: New directory `$1'\n";
1045 # Grab a handle to the SQLite db and do any necessary updates
1046 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1050 argsfromdir($updater);
1052 #$log->debug("update state : " . Dumper($state));
1054 my $last_dirname = "///";
1056 # foreach file specified on the command line ...
1057 foreach my $filename ( @{$state->{args}} )
1059 $filename = filecleanup($filename);
1061 $log->debug("Processing file $filename");
1063 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1065 my $cur_dirname = dirname($filename);
1066 if ( $cur_dirname ne $last_dirname )
1068 $last_dirname = $cur_dirname;
1069 if ( $cur_dirname eq "" )
1073 print "E cvs update: Updating $cur_dirname\n";
1077 # if we have a -C we should pretend we never saw modified stuff
1078 if ( exists ( $state->{opt}{C} ) )
1080 delete $state->{entries}{$filename}{modified_hash};
1081 delete $state->{entries}{$filename}{modified_filename};
1082 $state->{entries}{$filename}{unchanged} = 1;
1086 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^(1\.\d+)$/ )
1088 $meta = $updater->getmeta($filename, $1);
1090 $meta = $updater->getmeta($filename);
1093 # If -p was given, "print" the contents of the requested revision.
1094 if ( exists ( $state->{opt}{p} ) ) {
1095 if ( defined ( $meta->{revision} ) ) {
1096 $log->info("Printing '$filename' revision " . $meta->{revision});
1098 transmitfile($meta->{filehash}, { print => 1 });
1104 if ( ! defined $meta )
1113 my $oldmeta = $meta;
1115 my $wrev = revparse($filename);
1117 # If the working copy is an old revision, lets get that version too for comparison.
1118 if ( defined($wrev) and $wrev ne $meta->{revision} )
1120 $oldmeta = $updater->getmeta($filename, $wrev);
1123 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1125 # Files are up to date if the working copy and repo copy have the same revision,
1126 # and the working copy is unmodified _and_ the user hasn't specified -C
1127 next if ( defined ( $wrev )
1128 and defined($meta->{revision})
1129 and $wrev eq $meta->{revision}
1130 and $state->{entries}{$filename}{unchanged}
1131 and not exists ( $state->{opt}{C} ) );
1133 # If the working copy and repo copy have the same revision,
1134 # but the working copy is modified, tell the client it's modified
1135 if ( defined ( $wrev )
1136 and defined($meta->{revision})
1137 and $wrev eq $meta->{revision}
1138 and defined($state->{entries}{$filename}{modified_hash})
1139 and not exists ( $state->{opt}{C} ) )
1141 $log->info("Tell the client the file is modified");
1142 print "MT text M \n";
1143 print "MT fname $filename\n";
1144 print "MT newline\n";
1148 if ( $meta->{filehash} eq "deleted" )
1150 # TODO: If it has been modified in the sandbox, error out
1151 # with the appropriate message, rather than deleting a modified
1154 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1156 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1158 print "E cvs update: `$filename' is no longer in the repository\n";
1159 # Don't want to actually _DO_ the update if -n specified
1160 unless ( $state->{globaloptions}{-n} ) {
1161 print "Removed $dirpart\n";
1162 print "$filepart\n";
1165 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1166 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1167 or $meta->{filehash} eq 'added' )
1169 # normal update, just send the new revision (either U=Update,
1170 # or A=Add, or R=Remove)
1171 if ( defined($wrev) && ($wrev=~/^-/) )
1173 $log->info("Tell the client the file is scheduled for removal");
1174 print "MT text R \n";
1175 print "MT fname $filename\n";
1176 print "MT newline\n";
1179 elsif ( (!defined($wrev) || $wrev eq '0') &&
1180 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
1182 $log->info("Tell the client the file is scheduled for addition");
1183 print "MT text A \n";
1184 print "MT fname $filename\n";
1185 print "MT newline\n";
1190 $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
1191 print "MT +updated\n";
1192 print "MT text U \n";
1193 print "MT fname $filename\n";
1194 print "MT newline\n";
1195 print "MT -updated\n";
1198 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1200 # Don't want to actually _DO_ the update if -n specified
1201 unless ( $state->{globaloptions}{-n} )
1203 if ( defined ( $wrev ) )
1205 # instruct client we're sending a file to put in this path as a replacement
1206 print "Update-existing $dirpart\n";
1207 $log->debug("Updating existing file 'Update-existing $dirpart'");
1209 # instruct client we're sending a file to put in this path as a new file
1210 print "Clear-static-directory $dirpart\n";
1211 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1212 print "Clear-sticky $dirpart\n";
1213 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1215 $log->debug("Creating new file 'Created $dirpart'");
1216 print "Created $dirpart\n";
1218 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1220 # this is an "entries" line
1221 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1222 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1223 print "/$filepart/$meta->{revision}//$kopts/\n";
1226 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1227 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1230 transmitfile($meta->{filehash});
1233 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1235 my $mergeDir = setupTmpDir();
1237 my $file_local = $filepart . ".mine";
1238 my $mergedFile = "$mergeDir/$file_local";
1239 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1240 my $file_old = $filepart . "." . $oldmeta->{revision};
1241 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1242 my $file_new = $filepart . "." . $meta->{revision};
1243 transmitfile($meta->{filehash}, { targetfile => $file_new });
1245 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1246 $log->info("Merging $file_local, $file_old, $file_new");
1247 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1249 $log->debug("Temporary directory for merge is $mergeDir");
1251 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1258 $log->info("Merged successfully");
1259 print "M M $filename\n";
1260 $log->debug("Merged $dirpart");
1262 # Don't want to actually _DO_ the update if -n specified
1263 unless ( $state->{globaloptions}{-n} )
1265 print "Merged $dirpart\n";
1266 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1267 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1268 my $kopts = kopts_from_path("$dirpart/$filepart",
1269 "file",$mergedFile);
1270 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1271 print "/$filepart/$meta->{revision}//$kopts/\n";
1274 elsif ( $return == 1 )
1276 $log->info("Merged with conflicts");
1277 print "E cvs update: conflicts found in $filename\n";
1278 print "M C $filename\n";
1280 # Don't want to actually _DO_ the update if -n specified
1281 unless ( $state->{globaloptions}{-n} )
1283 print "Merged $dirpart\n";
1284 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1285 my $kopts = kopts_from_path("$dirpart/$filepart",
1286 "file",$mergedFile);
1287 print "/$filepart/$meta->{revision}/+/$kopts/\n";
1292 $log->warn("Merge failed");
1296 # Don't want to actually _DO_ the update if -n specified
1297 unless ( $state->{globaloptions}{-n} )
1300 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1301 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1303 # transmit file, format is single integer on a line by itself (file
1304 # size) followed by the file contents
1305 # TODO : we should copy files in blocks
1306 my $data = `cat $mergedFile`;
1307 $log->debug("File size : " . length($data));
1308 print length($data) . "\n";
1320 my ( $cmd, $data ) = @_;
1324 #$log->debug("State : " . Dumper($state));
1326 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1328 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1330 print "error 1 anonymous user cannot commit via pserver\n";
1335 if ( -e $state->{CVSROOT} . "/index" )
1337 $log->warn("file 'index' already exists in the git repository");
1338 print "error 1 Index already exists in git repo\n";
1343 # Grab a handle to the SQLite db and do any necessary updates
1344 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1347 # Remember where the head was at the beginning.
1348 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1350 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1351 print "error 1 pserver cannot find the current HEAD of module";
1356 setupWorkTree($parenthash);
1358 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1360 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1362 my @committedfiles = ();
1365 # foreach file specified on the command line ...
1366 foreach my $filename ( @{$state->{args}} )
1368 my $committedfile = $filename;
1369 $filename = filecleanup($filename);
1371 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1373 my $meta = $updater->getmeta($filename);
1374 $oldmeta{$filename} = $meta;
1376 my $wrev = revparse($filename);
1378 my ( $filepart, $dirpart ) = filenamesplit($filename);
1380 # do a checkout of the file if it is part of this tree
1382 system('git', 'checkout-index', '-f', '-u', $filename);
1384 die "Error running git-checkout-index -f -u $filename : $!";
1390 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1391 $addflag = 1 unless ( -e $filename );
1393 # Do up to date checking
1394 unless ( $addflag or $wrev eq $meta->{revision} or
1395 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1397 # fail everything if an up to date check fails
1398 print "error 1 Up to date check failed for $filename\n";
1403 push @committedfiles, $committedfile;
1404 $log->info("Committing $filename");
1406 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1410 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1411 rename $state->{entries}{$filename}{modified_filename},$filename;
1413 # Calculate modes to remove
1415 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1417 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1418 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1423 $log->info("Removing file '$filename'");
1425 system("git", "update-index", "--remove", $filename);
1429 $log->info("Adding file '$filename'");
1430 system("git", "update-index", "--add", $filename);
1432 $log->info("UpdatingX2 file '$filename'");
1433 system("git", "update-index", $filename);
1437 unless ( scalar(@committedfiles) > 0 )
1439 print "E No files to commit\n";
1445 my $treehash = `git write-tree`;
1448 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1450 # write our commit message out if we have one ...
1451 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1452 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1453 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1454 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1455 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1458 print $msg_fh "\n\nvia git-CVS emulator\n";
1462 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1464 $log->info("Commit hash : $commithash");
1466 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1468 $log->warn("Commit failed (Invalid commit hash)");
1469 print "error 1 Commit failed (unknown reason)\n";
1474 ### Emulate git-receive-pack by running hooks/update
1475 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1476 $parenthash, $commithash );
1478 unless( system( @hook ) == 0 )
1480 $log->warn("Commit failed (update hook declined to update ref)");
1481 print "error 1 Commit failed (update hook declined)\n";
1488 if (system(qw(git update-ref -m), "cvsserver ci",
1489 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1490 $log->warn("update-ref for $state->{module} failed.");
1491 print "error 1 Cannot commit -- update first\n";
1496 ### Emulate git-receive-pack by running hooks/post-receive
1497 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1499 open(my $pipe, "| $hook") || die "can't fork $!";
1501 local $SIG{PIPE} = sub { die 'pipe broke' };
1503 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1505 close $pipe || die "bad pipe: $! $?";
1510 ### Then hooks/post-update
1511 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1513 system($hook, "refs/heads/$state->{module}");
1516 # foreach file specified on the command line ...
1517 foreach my $filename ( @committedfiles )
1519 $filename = filecleanup($filename);
1521 my $meta = $updater->getmeta($filename);
1522 unless (defined $meta->{revision}) {
1523 $meta->{revision} = "1.1";
1526 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1528 $log->debug("Checked-in $dirpart : $filename");
1530 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1531 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1533 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1534 print "Remove-entry $dirpart\n";
1535 print "$filename\n";
1537 if ($meta->{revision} eq "1.1") {
1538 print "M initial revision: 1.1\n";
1540 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1542 print "Checked-in $dirpart\n";
1543 print "$filename\n";
1544 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1545 print "/$filepart/$meta->{revision}//$kopts/\n";
1555 my ( $cmd, $data ) = @_;
1559 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1560 #$log->debug("status state : " . Dumper($state));
1562 # Grab a handle to the SQLite db and do any necessary updates
1564 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1567 # if no files were specified, we need to work out what files we should
1568 # be providing status on ...
1569 argsfromdir($updater);
1571 # foreach file specified on the command line ...
1572 foreach my $filename ( @{$state->{args}} )
1574 $filename = filecleanup($filename);
1576 if ( exists($state->{opt}{l}) &&
1577 index($filename, '/', length($state->{prependdir})) >= 0 )
1582 my $meta = $updater->getmeta($filename);
1583 my $oldmeta = $meta;
1585 my $wrev = revparse($filename);
1587 # If the working copy is an old revision, lets get that
1588 # version too for comparison.
1589 if ( defined($wrev) and $wrev ne $meta->{revision} )
1591 $oldmeta = $updater->getmeta($filename, $wrev);
1594 # TODO : All possible statuses aren't yet implemented
1596 # Files are up to date if the working copy and repo copy have
1597 # the same revision, and the working copy is unmodified
1598 if ( defined ( $wrev ) and defined($meta->{revision}) and
1599 $wrev eq $meta->{revision} and
1600 ( ( $state->{entries}{$filename}{unchanged} and
1601 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1602 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1603 ( defined($state->{entries}{$filename}{modified_hash}) and
1604 $state->{entries}{$filename}{modified_hash} eq
1605 $meta->{filehash} ) ) )
1607 $status = "Up-to-date"
1610 # Need checkout if the working copy has a different (usually
1611 # older) revision than the repo copy, and the working copy is
1613 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1614 $meta->{revision} ne $wrev and
1615 ( $state->{entries}{$filename}{unchanged} or
1616 ( defined($state->{entries}{$filename}{modified_hash}) and
1617 $state->{entries}{$filename}{modified_hash} eq
1618 $oldmeta->{filehash} ) ) )
1620 $status ||= "Needs Checkout";
1623 # Need checkout if it exists in the repo but doesn't have a working
1625 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1627 $status ||= "Needs Checkout";
1630 # Locally modified if working copy and repo copy have the
1631 # same revision but there are local changes
1632 if ( defined ( $wrev ) and defined($meta->{revision}) and
1633 $wrev eq $meta->{revision} and
1634 $state->{entries}{$filename}{modified_filename} )
1636 $status ||= "Locally Modified";
1639 # Needs Merge if working copy revision is different
1640 # (usually older) than repo copy and there are local changes
1641 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1642 $meta->{revision} ne $wrev and
1643 $state->{entries}{$filename}{modified_filename} )
1645 $status ||= "Needs Merge";
1648 if ( defined ( $state->{entries}{$filename}{revision} ) and
1649 not defined ( $meta->{revision} ) )
1651 $status ||= "Locally Added";
1653 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1654 $wrev eq "-$meta->{revision}" )
1656 $status ||= "Locally Removed";
1658 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1659 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1661 $status ||= "Unresolved Conflict";
1665 $status ||= "File had conflicts on merge";
1668 $status ||= "Unknown";
1670 my ($filepart) = filenamesplit($filename);
1672 print "M =======" . ( "=" x 60 ) . "\n";
1673 print "M File: $filepart\tStatus: $status\n";
1674 if ( defined($state->{entries}{$filename}{revision}) )
1676 print "M Working revision:\t" .
1677 $state->{entries}{$filename}{revision} . "\n";
1679 print "M Working revision:\tNo entry for $filename\n";
1681 if ( defined($meta->{revision}) )
1683 print "M Repository revision:\t" .
1685 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1686 print "M Sticky Tag:\t\t(none)\n";
1687 print "M Sticky Date:\t\t(none)\n";
1688 print "M Sticky Options:\t\t(none)\n";
1690 print "M Repository revision:\tNo revision control file\n";
1700 my ( $cmd, $data ) = @_;
1704 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1705 #$log->debug("status state : " . Dumper($state));
1707 my ($revision1, $revision2);
1708 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1710 $revision1 = $state->{opt}{r}[0];
1711 $revision2 = $state->{opt}{r}[1];
1713 $revision1 = $state->{opt}{r};
1716 $log->debug("Diffing revisions " .
1717 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1718 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1720 # Grab a handle to the SQLite db and do any necessary updates
1722 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1725 # if no files were specified, we need to work out what files we should
1726 # be providing status on ...
1727 argsfromdir($updater);
1729 # foreach file specified on the command line ...
1730 foreach my $filename ( @{$state->{args}} )
1732 $filename = filecleanup($filename);
1734 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1736 my $wrev = revparse($filename);
1738 # We need _something_ to diff against
1739 next unless ( defined ( $wrev ) );
1741 # if we have a -r switch, use it
1742 if ( defined ( $revision1 ) )
1744 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1745 $meta1 = $updater->getmeta($filename, $revision1);
1746 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1748 print "E File $filename at revision $revision1 doesn't exist\n";
1751 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1753 # otherwise we just use the working copy revision
1756 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1757 $meta1 = $updater->getmeta($filename, $wrev);
1758 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1761 # if we have a second -r switch, use it too
1762 if ( defined ( $revision2 ) )
1764 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1765 $meta2 = $updater->getmeta($filename, $revision2);
1767 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1769 print "E File $filename at revision $revision2 doesn't exist\n";
1773 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1775 # otherwise we just use the working copy
1778 $file2 = $state->{entries}{$filename}{modified_filename};
1781 # if we have been given -r, and we don't have a $file2 yet, lets
1783 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1785 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1786 $meta2 = $updater->getmeta($filename, $wrev);
1787 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1790 # We need to have retrieved something useful
1791 next unless ( defined ( $meta1 ) );
1793 # Files to date if the working copy and repo copy have the same
1794 # revision, and the working copy is unmodified
1795 if ( not defined ( $meta2 ) and $wrev eq $meta1->{revision} and
1796 ( ( $state->{entries}{$filename}{unchanged} and
1797 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1798 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1799 ( defined($state->{entries}{$filename}{modified_hash}) and
1800 $state->{entries}{$filename}{modified_hash} eq
1801 $meta1->{filehash} ) ) )
1806 # Apparently we only show diffs for locally modified files
1807 unless ( defined($meta2) or
1808 defined ( $state->{entries}{$filename}{modified_filename} ) )
1813 print "M Index: $filename\n";
1814 print "M =======" . ( "=" x 60 ) . "\n";
1815 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1816 if ( defined ( $meta1 ) )
1818 print "M retrieving revision $meta1->{revision}\n"
1820 if ( defined ( $meta2 ) )
1822 print "M retrieving revision $meta2->{revision}\n"
1825 foreach my $opt ( keys %{$state->{opt}} )
1827 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1829 foreach my $value ( @{$state->{opt}{$opt}} )
1831 print "-$opt $value ";
1835 if ( defined ( $state->{opt}{$opt} ) )
1837 print "$state->{opt}{$opt} "
1841 print "$filename\n";
1843 $log->info("Diffing $filename -r $meta1->{revision} -r " .
1844 ( $meta2->{revision} or "workingcopy" ));
1846 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1848 if ( exists $state->{opt}{u} )
1850 system("diff -u -L '$filename revision $meta1->{revision}'" .
1852 ( defined($meta2->{revision}) ?
1853 "revision $meta2->{revision}" :
1855 "' $file1 $file2 > $filediff" );
1857 system("diff $file1 $file2 > $filediff");
1872 my ( $cmd, $data ) = @_;
1876 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1877 #$log->debug("log state : " . Dumper($state));
1880 if ( defined ( $state->{opt}{r} ) )
1882 $revFilter = $state->{opt}{r};
1885 # Grab a handle to the SQLite db and do any necessary updates
1887 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1890 # if no files were specified, we need to work out what files we
1891 # should be providing status on ...
1892 argsfromdir($updater);
1894 # foreach file specified on the command line ...
1895 foreach my $filename ( @{$state->{args}} )
1897 $filename = filecleanup($filename);
1899 my $headmeta = $updater->getmeta($filename);
1901 my ($revisions,$totalrevisions) = $updater->getlog($filename,
1904 next unless ( scalar(@$revisions) );
1907 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1908 print "M Working file: $filename\n";
1909 print "M head: $headmeta->{revision}\n";
1910 print "M branch:\n";
1911 print "M locks: strict\n";
1912 print "M access list:\n";
1913 print "M symbolic names:\n";
1914 print "M keyword substitution: kv\n";
1915 print "M total revisions: $totalrevisions;\tselected revisions: " .
1916 scalar(@$revisions) . "\n";
1917 print "M description:\n";
1919 foreach my $revision ( @$revisions )
1921 print "M ----------------------------\n";
1922 print "M revision $revision->{revision}\n";
1923 # reformat the date for log output
1924 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
1925 defined($DATE_LIST->{$2}) )
1927 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
1928 $3, $DATE_LIST->{$2}, $1, $4 );
1930 $revision->{author} = cvs_author($revision->{author});
1931 print "M date: $revision->{modified};" .
1932 " author: $revision->{author}; state: " .
1933 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
1936 $commitmessage = $updater->commitmessage($revision->{commithash});
1937 $commitmessage =~ s/^/M /mg;
1938 print $commitmessage . "\n";
1940 print "M =======" . ( "=" x 70 ) . "\n";
1948 my ( $cmd, $data ) = @_;
1950 argsplit("annotate");
1952 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1953 #$log->debug("status state : " . Dumper($state));
1955 # Grab a handle to the SQLite db and do any necessary updates
1956 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1959 # if no files were specified, we need to work out what files we should be providing annotate on ...
1960 argsfromdir($updater);
1962 # we'll need a temporary checkout dir
1965 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1967 # foreach file specified on the command line ...
1968 foreach my $filename ( @{$state->{args}} )
1970 $filename = filecleanup($filename);
1972 my $meta = $updater->getmeta($filename);
1974 next unless ( $meta->{revision} );
1976 # get all the commits that this file was in
1977 # in dense format -- aka skip dead revisions
1978 my $revisions = $updater->gethistorydense($filename);
1979 my $lastseenin = $revisions->[0][2];
1981 # populate the temporary index based on the latest commit were we saw
1982 # the file -- but do it cheaply without checking out any files
1983 # TODO: if we got a revision from the client, use that instead
1984 # to look up the commithash in sqlite (still good to default to
1985 # the current head as we do now)
1986 system("git", "read-tree", $lastseenin);
1989 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1992 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1994 # do a checkout of the file
1995 system('git', 'checkout-index', '-f', '-u', $filename);
1997 print "E error running git-checkout-index -f -u $filename : $!\n";
2001 $log->info("Annotate $filename");
2003 # Prepare a file with the commits from the linearized
2004 # history that annotate should know about. This prevents
2005 # git-jsannotate telling us about commits we are hiding
2008 my $a_hints = "$work->{workDir}/.annotate_hints";
2009 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2010 print "E failed to open '$a_hints' for writing: $!\n";
2013 for (my $i=0; $i < @$revisions; $i++)
2015 print ANNOTATEHINTS $revisions->[$i][2];
2016 if ($i+1 < @$revisions) { # have we got a parent?
2017 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2019 print ANNOTATEHINTS "\n";
2022 print ANNOTATEHINTS "\n";
2024 or (print "E failed to write $a_hints: $!\n"), return;
2026 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2027 if (!open(ANNOTATE, "-|", @cmd)) {
2028 print "E error invoking ". join(' ',@cmd) .": $!\n";
2032 print "E Annotations for $filename\n";
2033 print "E ***************\n";
2034 while ( <ANNOTATE> )
2036 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2038 my $commithash = $1;
2040 unless ( defined ( $metadata->{$commithash} ) )
2042 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2043 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
2044 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2046 printf("M %-7s (%-8s %10s): %s\n",
2047 $metadata->{$commithash}{revision},
2048 $metadata->{$commithash}{author},
2049 $metadata->{$commithash}{modified},
2053 $log->warn("Error in annotate output! LINE: $_");
2054 print "E Annotate error \n";
2061 # done; get out of the tempdir
2068 # This method takes the state->{arguments} array and produces two new arrays.
2069 # The first is $state->{args} which is everything before the '--' argument, and
2070 # the second is $state->{files} which is everything after it.
2073 $state->{args} = [];
2074 $state->{files} = [];
2077 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2081 if ( defined($type) )
2084 $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" );
2085 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2086 $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" );
2087 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2088 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2089 $opt = { k => 1, m => 1 } if ( $type eq "add" );
2090 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2091 $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" );
2094 while ( scalar ( @{$state->{arguments}} ) > 0 )
2096 my $arg = shift @{$state->{arguments}};
2098 next if ( $arg eq "--" );
2099 next unless ( $arg =~ /\S/ );
2101 # if the argument looks like a switch
2102 if ( $arg =~ /^-(\w)(.*)/ )
2104 # if it's a switch that takes an argument
2107 # If this switch has already been provided
2108 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2110 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2111 if ( length($2) > 0 )
2113 push @{$state->{opt}{$1}},$2;
2115 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2118 # if there's extra data in the arg, use that as the argument for the switch
2119 if ( length($2) > 0 )
2121 $state->{opt}{$1} = $2;
2123 $state->{opt}{$1} = shift @{$state->{arguments}};
2127 $state->{opt}{$1} = undef;
2132 push @{$state->{args}}, $arg;
2140 foreach my $value ( @{$state->{arguments}} )
2142 if ( $value eq "--" )
2147 push @{$state->{args}}, $value if ( $mode == 0 );
2148 push @{$state->{files}}, $value if ( $mode == 1 );
2153 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2156 my $updater = shift;
2158 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2160 return if ( scalar ( @{$state->{args}} ) > 1 );
2162 my @gethead = @{$updater->gethead};
2165 foreach my $file (keys %{$state->{entries}}) {
2166 if ( exists $state->{entries}{$file}{revision} &&
2167 $state->{entries}{$file}{revision} eq '0' )
2169 push @gethead, { name => $file, filehash => 'added' };
2173 if ( scalar(@{$state->{args}}) == 1 )
2175 my $arg = $state->{args}[0];
2176 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2178 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2180 foreach my $file ( @gethead )
2182 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2183 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2184 push @{$state->{args}}, $file->{name};
2187 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2189 $log->info("Only one arg specified, populating file list automatically");
2191 $state->{args} = [];
2193 foreach my $file ( @gethead )
2195 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2196 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2197 push @{$state->{args}}, $file->{name};
2202 # This method cleans up the $state variable after a command that uses arguments has run
2205 $state->{files} = [];
2206 $state->{args} = [];
2207 $state->{arguments} = [];
2208 $state->{entries} = {};
2211 # Return working directory CVS revision "1.X" out
2212 # of the the working directory "entries" state, for the given filename.
2213 # This is prefixed with a dash if the file is scheduled for removal
2214 # when it is committed.
2217 my $filename = shift;
2219 return $state->{entries}{$filename}{revision};
2222 # This method takes a file hash and does a CVS "file transfer". Its
2223 # exact behaviour depends on a second, optional hash table argument:
2224 # - If $options->{targetfile}, dump the contents to that file;
2225 # - If $options->{print}, use M/MT to transmit the contents one line
2227 # - Otherwise, transmit the size of the file, followed by the file
2231 my $filehash = shift;
2232 my $options = shift;
2234 if ( defined ( $filehash ) and $filehash eq "deleted" )
2236 $log->warn("filehash is 'deleted'");
2240 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2242 my $type = `git cat-file -t $filehash`;
2245 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2247 my $size = `git cat-file -s $filehash`;
2250 $log->debug("transmitfile($filehash) size=$size, type=$type");
2252 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2254 if ( defined ( $options->{targetfile} ) )
2256 my $targetfile = $options->{targetfile};
2257 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2258 print NEWFILE $_ while ( <$fh> );
2259 close NEWFILE or die("Failed to write '$targetfile': $!");
2260 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2265 print 'MT text ', $_, "\n";
2270 print while ( <$fh> );
2272 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2274 die("Couldn't execute git-cat-file");
2278 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2279 # refers to the directory portion and the file portion of the filename
2283 my $filename = shift;
2284 my $fixforlocaldir = shift;
2286 my ( $filepart, $dirpart ) = ( $filename, "." );
2287 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2290 if ( $fixforlocaldir )
2292 $dirpart =~ s/^$state->{prependdir}//;
2295 return ( $filepart, $dirpart );
2300 my $filename = shift;
2302 return undef unless(defined($filename));
2303 if ( $filename =~ /^\// )
2305 print "E absolute filenames '$filename' not supported by server\n";
2309 $filename =~ s/^\.\///g;
2310 $filename = $state->{prependdir} . $filename;
2316 if( !defined($state->{CVSROOT}) )
2318 print "error 1 CVSROOT not specified\n";
2322 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2324 print "error 1 Internally inconsistent CVSROOT\n";
2330 # Setup working directory in a work tree with the requested version
2331 # loaded in the index.
2338 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2339 defined($work->{tmpDir}) )
2341 $log->warn("Bad work tree state management");
2342 print "error 1 Internal setup multiple work trees without cleanup\n";
2347 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2349 if( !defined($work->{index}) )
2351 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2354 chdir $work->{workDir} or
2355 die "Unable to chdir to $work->{workDir}\n";
2357 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2359 $ENV{GIT_WORK_TREE} = ".";
2360 $ENV{GIT_INDEX_FILE} = $work->{index};
2365 system("git","read-tree",$ver);
2368 $log->warn("Error running git-read-tree");
2369 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2372 # else # req_annotate reads tree for each file
2375 # Ensure current directory is in some kind of working directory,
2376 # with a recent version loaded in the index.
2379 if( defined($work->{tmpDir}) )
2381 $log->warn("Bad work tree state management [ensureWorkTree()]");
2382 print "error 1 Internal setup multiple dirs without cleanup\n";
2386 if( $work->{state} )
2393 if( !defined($work->{emptyDir}) )
2395 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2397 chdir $work->{emptyDir} or
2398 die "Unable to chdir to $work->{emptyDir}\n";
2400 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2402 if ($ver !~ /^[0-9a-f]{40}$/)
2404 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2405 print "error 1 cannot find the current HEAD of module";
2410 if( !defined($work->{index}) )
2412 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2415 $ENV{GIT_WORK_TREE} = ".";
2416 $ENV{GIT_INDEX_FILE} = $work->{index};
2419 system("git","read-tree",$ver);
2422 die "Error running git-read-tree $ver $!\n";
2426 # Cleanup working directory that is not needed any longer.
2429 if( ! $work->{state} )
2434 chdir "/" or die "Unable to chdir '/'\n";
2436 if( defined($work->{workDir}) )
2438 rmtree( $work->{workDir} );
2439 undef $work->{workDir};
2441 undef $work->{state};
2444 # Setup a temporary directory (not a working tree), typically for
2445 # merging dirty state as in req_update.
2448 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2449 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2451 return $work->{tmpDir};
2454 # Clean up a previously setupTmpDir. Restore previous work tree if
2458 if ( !defined($work->{tmpDir}) )
2460 $log->warn("cleanup tmpdir that has not been setup");
2461 die "Cleanup tmpDir that has not been setup\n";
2463 if( defined($work->{state}) )
2465 if( $work->{state} == 1 )
2467 chdir $work->{emptyDir} or
2468 die "Unable to chdir to $work->{emptyDir}\n";
2470 elsif( $work->{state} == 2 )
2472 chdir $work->{workDir} or
2473 die "Unable to chdir to $work->{emptyDir}\n";
2477 $log->warn("Inconsistent work dir state");
2478 die "Inconsistent work dir state\n";
2483 chdir "/" or die "Unable to chdir '/'\n";
2487 # Given a path, this function returns a string containing the kopts
2488 # that should go into that path's Entries line. For example, a binary
2489 # file should get -kb.
2492 my ($path, $srcType, $name) = @_;
2494 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2495 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2497 my ($val) = check_attr( "text", $path );
2498 if ( $val eq "unspecified" )
2500 $val = check_attr( "crlf", $path );
2502 if ( $val eq "unset" )
2506 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2507 $val eq "set" || $val eq "input" )
2513 $log->info("Unrecognized check_attr crlf $path : $val");
2517 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2519 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2523 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2525 if( is_binary($srcType,$name) )
2527 $log->debug("... as binary");
2532 $log->debug("... as text");
2536 # Return "" to give no special treatment to any path
2542 my ($attr,$path) = @_;
2544 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2548 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2557 # This should have the same heuristics as convert.c:is_binary() and related.
2558 # Note that the bare CR test is done by callers in convert.c.
2561 my ($srcType,$name) = @_;
2562 $log->debug("is_binary($srcType,$name)");
2564 # Minimize amount of interpreted code run in the inner per-character
2565 # loop for large files, by totalling each character value and
2566 # then analyzing the totals.
2569 for($i=0;$i<256;$i++)
2574 my $fh = open_blob_or_die($srcType,$name);
2576 while( defined($line=<$fh>) )
2578 # Any '\0' and bare CR are considered binary.
2579 if( $line =~ /\0|(\r[^\n])/ )
2585 # Count up each character in the line:
2586 my $len=length($line);
2587 for($i=0;$i<$len;$i++)
2589 $counts[ord(substr($line,$i,1))]++;
2594 # Don't count CR and LF as either printable/nonprintable
2595 $counts[ord("\n")]=0;
2596 $counts[ord("\r")]=0;
2598 # Categorize individual character count into printable and nonprintable:
2601 for($i=0;$i<256;$i++)
2609 $nonprintable+=$counts[$i];
2611 elsif( $i==127 ) # DEL
2613 $nonprintable+=$counts[$i];
2617 $printable+=$counts[$i];
2621 return ($printable >> 7) < $nonprintable;
2624 # Returns open file handle. Possible invocations:
2625 # - open_blob_or_die("file",$filename);
2626 # - open_blob_or_die("sha1",$filehash);
2627 sub open_blob_or_die
2629 my ($srcType,$name) = @_;
2631 if( $srcType eq "file" )
2633 if( !open $fh,"<",$name )
2635 $log->warn("Unable to open file $name: $!");
2636 die "Unable to open file $name: $!\n";
2639 elsif( $srcType eq "sha1" )
2641 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2643 $log->warn("Need filehash");
2644 die "Need filehash\n";
2647 my $type = `git cat-file -t $name`;
2650 unless ( defined ( $type ) and $type eq "blob" )
2652 $log->warn("Invalid type '$type' for '$name'");
2653 die ( "Invalid type '$type' (expected 'blob')" )
2656 my $size = `git cat-file -s $name`;
2659 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2661 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2663 $log->warn("Unable to open sha1 $name");
2664 die "Unable to open sha1 $name\n";
2669 $log->warn("Unknown type of blob source: $srcType");
2670 die "Unknown type of blob source: $srcType\n";
2675 # Generate a CVS author name from Git author information, by taking the local
2676 # part of the email address and replacing characters not in the Portable
2677 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2678 # Login names are Unix login names, which should be restricted to this
2682 my $author_line = shift;
2683 (my $author) = $author_line =~ /<([^@>]*)/;
2685 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2694 # This table is from src/scramble.c in the CVS source
2696 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2697 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2698 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2699 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2700 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2701 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2702 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2703 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2704 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2705 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2706 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2707 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2708 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2709 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2710 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2711 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2715 # This should never happen, the same password format (A) has been
2716 # used by CVS since the beginning of time
2718 my $fmt = substr($str, 0, 1);
2719 die "invalid password format `$fmt'" unless $fmt eq 'A';
2722 my @str = unpack "C*", substr($str, 1);
2723 my $ret = join '', map { chr $SHIFTS[$_] } @str;
2728 package GITCVS::log;
2731 #### Copyright The Open University UK - 2006.
2733 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2734 #### Martin Langhoff <martin@laptop.org>
2747 This module provides very crude logging with a similar interface to
2756 Creates a new log object, optionally you can specify a filename here to
2757 indicate the file to log to. If no log file is specified, you can specify one
2758 later with method setfile, or indicate you no longer want logging with method
2761 Until one of these methods is called, all log calls will buffer messages ready
2768 my $filename = shift;
2772 bless $self, $class;
2774 if ( defined ( $filename ) )
2776 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2784 This methods takes a filename, and attempts to open that file as the log file.
2785 If successful, all buffered data is written out to the file, and any further
2786 logging is written directly to the file.
2792 my $filename = shift;
2794 if ( defined ( $filename ) )
2796 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2799 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2801 while ( my $line = shift @{$self->{buffer}} )
2803 print {$self->{fh}} $line;
2809 This method indicates no logging is going to be used. It flushes any entries in
2810 the internal buffer, and sets a flag to ensure no further data is put there.
2819 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2821 $self->{buffer} = [];
2826 Internal method. Returns true if the log file is open, false otherwise.
2833 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2837 =head2 debug info warn fatal
2839 These four methods are wrappers to _log. They provide the actual interface for
2843 sub debug { my $self = shift; $self->_log("debug", @_); }
2844 sub info { my $self = shift; $self->_log("info" , @_); }
2845 sub warn { my $self = shift; $self->_log("warn" , @_); }
2846 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2850 This is an internal method called by the logging functions. It generates a
2851 timestamp and pushes the logged line either to file, or internal buffer.
2859 return if ( $self->{nolog} );
2861 my @time = localtime;
2862 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2872 if ( $self->_logopen )
2874 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2876 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2882 This method simply closes the file handle if one is open
2889 if ( $self->_logopen )
2895 package GITCVS::updater;
2898 #### Copyright The Open University UK - 2006.
2900 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2901 #### Martin Langhoff <martin@laptop.org>
2923 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2924 die "Need to specify a module" unless ( defined($module) );
2926 $class = ref($class) || $class;
2930 bless $self, $class;
2932 $self->{valid_tables} = {'revision' => 1,
2933 'revision_ix1' => 1,
2934 'revision_ix2' => 1,
2940 $self->{module} = $module;
2941 $self->{git_path} = $config . "/";
2943 $self->{log} = $log;
2945 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2947 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2948 $cfg->{gitcvs}{dbdriver} || "SQLite";
2949 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2950 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2951 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2952 $cfg->{gitcvs}{dbuser} || "";
2953 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2954 $cfg->{gitcvs}{dbpass} || "";
2955 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2956 $cfg->{gitcvs}{dbtablenameprefix} || "";
2957 my %mapping = ( m => $module,
2958 a => $state->{method},
2959 u => getlogin || getpwuid($<) || $<,
2960 G => $self->{git_path},
2961 g => mangle_dirname($self->{git_path}),
2963 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2964 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2965 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2966 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2968 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2969 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2970 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2973 die "Error connecting to database\n" unless defined $self->{dbh};
2975 $self->{tables} = {};
2976 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2978 $self->{tables}{$table} = 1;
2981 # Construct the revision table if required
2982 # The revision table stores an entry for each file, each time that file
2984 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
2985 # This is not sufficient to support "-r {commithash}" for any
2986 # files except files that were modified by that commit (also,
2987 # some places in the code ignore/effectively strip out -r in
2988 # some cases, before it gets passed to getmeta()).
2989 # The "filehash" field typically has a git blob hash, but can also
2990 # be set to "dead" to indicate that the given version of the file
2991 # should not exist in the sandbox.
2992 unless ( $self->{tables}{$self->tablename("revision")} )
2994 my $tablename = $self->tablename("revision");
2995 my $ix1name = $self->tablename("revision_ix1");
2996 my $ix2name = $self->tablename("revision_ix2");
2998 CREATE TABLE $tablename (
3000 revision INTEGER NOT NULL,
3001 filehash TEXT NOT NULL,
3002 commithash TEXT NOT NULL,
3003 author TEXT NOT NULL,
3004 modified TEXT NOT NULL,
3009 CREATE INDEX $ix1name
3010 ON $tablename (name,revision)
3013 CREATE INDEX $ix2name
3014 ON $tablename (name,commithash)
3018 # Construct the head table if required
3019 # The head table (along with the "last_commit" entry in the property
3020 # table) is the persisted working state of the "sub update" subroutine.
3021 # All of it's data is read entirely first, and completely recreated
3022 # last, every time "sub update" runs.
3023 # This is also used by "sub getmeta" when it is asked for the latest
3024 # version of a file (as opposed to some specific version).
3025 # Another way of thinking about it is as a single slice out of
3026 # "revisions", giving just the most recent revision information for
3028 unless ( $self->{tables}{$self->tablename("head")} )
3030 my $tablename = $self->tablename("head");
3031 my $ix1name = $self->tablename("head_ix1");
3033 CREATE TABLE $tablename (
3035 revision INTEGER NOT NULL,
3036 filehash TEXT NOT NULL,
3037 commithash TEXT NOT NULL,
3038 author TEXT NOT NULL,
3039 modified TEXT NOT NULL,
3044 CREATE INDEX $ix1name
3045 ON $tablename (name)
3049 # Construct the properties table if required
3050 # - "last_commit" - Used by "sub update".
3051 unless ( $self->{tables}{$self->tablename("properties")} )
3053 my $tablename = $self->tablename("properties");
3055 CREATE TABLE $tablename (
3056 key TEXT NOT NULL PRIMARY KEY,
3062 # Construct the commitmsgs table if required
3063 # The commitmsgs table is only used for merge commits, since
3064 # "sub update" will only keep one branch of parents. Shortlogs
3065 # for ignored commits (i.e. not on the chosen branch) will be used
3066 # to construct a replacement "collapsed" merge commit message,
3067 # which will be stored in this table. See also "sub commitmessage".
3068 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3070 my $tablename = $self->tablename("commitmsgs");
3072 CREATE TABLE $tablename (
3073 key TEXT NOT NULL PRIMARY KEY,
3090 if (exists $self->{valid_tables}{$name}) {
3091 return $self->{dbtablenameprefix} . $name;
3099 Bring the database up to date with the latest changes from
3102 Internal working state is read out of the "head" table and the
3103 "last_commit" property, then it updates "revisions" based on that, and
3104 finally it writes the new internal state back to the "head" table
3105 so it can be used as a starting point the next time update is called.
3112 # first lets get the commit list
3113 $ENV{GIT_DIR} = $self->{git_path};
3115 my $commitsha1 = `git rev-parse $self->{module}`;
3118 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3119 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3121 die("Invalid module '$self->{module}'");
3126 my $lastcommit = $self->_get_prop("last_commit");
3128 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3132 # Start exclusive lock here...
3133 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3135 # TODO: log processing is memory bound
3136 # if we can parse into a 2nd file that is in reverse order
3137 # we can probably do something really efficient
3138 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3140 if (defined $lastcommit) {
3141 push @git_log_params, "$lastcommit..$self->{module}";
3143 push @git_log_params, $self->{module};
3145 # git-rev-list is the backend / plumbing version of git-log
3146 open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3155 if (m/^commit\s+(.*)$/) {
3156 # on ^commit lines put the just seen commit in the stack
3157 # and prime things for the next one
3160 unshift @commits, \%copy;
3163 my @parents = split(m/\s+/, $1);
3164 $commit{hash} = shift @parents;
3165 $commit{parents} = \@parents;
3166 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3167 # on rfc822-like lines seen before we see any message,
3168 # lowercase the entry and put it in the hash as key-value
3169 $commit{lc($1)} = $2;
3171 # message lines - skip initial empty line
3172 # and trim whitespace
3173 if (!exists($commit{message}) && m/^\s*$/) {
3174 # define it to mark the end of headers
3175 $commit{message} = '';
3178 s/^\s+//; s/\s+$//; # trim ws
3179 $commit{message} .= $_ . "\n";
3184 unshift @commits, \%commit if ( keys %commit );
3186 # Now all the commits are in the @commits bucket
3187 # ordered by time DESC. for each commit that needs processing,
3188 # determine whether it's following the last head we've seen or if
3189 # it's on its own branch, grab a file list, and add whatever's changed
3190 # NOTE: $lastcommit refers to the last commit from previous run
3191 # $lastpicked is the last commit we picked in this run
3194 if (defined $lastcommit) {
3195 $lastpicked = $lastcommit;
3198 my $committotal = scalar(@commits);
3199 my $commitcount = 0;
3201 # Load the head table into $head (for cached lookups during the update process)
3202 foreach my $file ( @{$self->gethead(1)} )
3204 $head->{$file->{name}} = $file;
3207 foreach my $commit ( @commits )
3209 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3210 if (defined $lastpicked)
3212 if (!in_array($lastpicked, @{$commit->{parents}}))
3214 # skip, we'll see this delta
3215 # as part of a merge later
3216 # warn "skipping off-track $commit->{hash}\n";
3218 } elsif (@{$commit->{parents}} > 1) {
3219 # it is a merge commit, for each parent that is
3220 # not $lastpicked (not given a CVS revision number),
3221 # see if we can get a log
3222 # from the merge-base to that parent to put it
3223 # in the message as a merge summary.
3224 my @parents = @{$commit->{parents}};
3225 foreach my $parent (@parents) {
3226 if ($parent eq $lastpicked) {
3229 # git-merge-base can potentially (but rarely) throw
3230 # several candidate merge bases. let's assume
3231 # that the first one is the best one.
3233 safe_pipe_capture('git', 'merge-base',
3234 $lastpicked, $parent);
3236 # The two branches may not be related at all,
3237 # in which case merge base simply fails to find
3238 # any, but that's Ok.
3244 # print "want to log between $base $parent \n";
3245 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3246 or die "Cannot call git-log: $!";
3250 if (!defined $mergedhash) {
3251 if (m/^commit\s+(.+)$/) {
3257 # grab the first line that looks non-rfc822
3258 # aka has content after leading space
3259 if (m/^\s+(\S.*)$/) {
3261 $title = substr($title,0,100); # truncate
3262 unshift @merged, "$mergedhash $title";
3269 $commit->{mergemsg} = $commit->{message};
3270 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3271 foreach my $summary (@merged) {
3272 $commit->{mergemsg} .= "\t$summary\n";
3274 $commit->{mergemsg} .= "\n\n";
3275 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3282 # convert the date to CVS-happy format
3283 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3285 if ( defined ( $lastpicked ) )
3287 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3289 while ( <FILELIST> )
3292 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3294 die("Couldn't process git-diff-tree line : $_");
3296 my ($mode, $hash, $change) = ($1, $2, $3);
3297 my $name = <FILELIST>;
3300 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3303 $git_perms .= "r" if ( $mode & 4 );
3304 $git_perms .= "w" if ( $mode & 2 );
3305 $git_perms .= "x" if ( $mode & 1 );
3306 $git_perms = "rw" if ( $git_perms eq "" );
3308 if ( $change eq "D" )
3310 #$log->debug("DELETE $name");
3313 revision => $head->{$name}{revision} + 1,
3314 filehash => "deleted",
3315 commithash => $commit->{hash},
3316 modified => $commit->{date},
3317 author => $commit->{author},
3320 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3322 elsif ( $change eq "M" || $change eq "T" )
3324 #$log->debug("MODIFIED $name");
3327 revision => $head->{$name}{revision} + 1,
3329 commithash => $commit->{hash},
3330 modified => $commit->{date},
3331 author => $commit->{author},
3334 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3336 elsif ( $change eq "A" )
3338 #$log->debug("ADDED $name");
3341 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3343 commithash => $commit->{hash},
3344 modified => $commit->{date},
3345 author => $commit->{author},
3348 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3352 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3358 # this is used to detect files removed from the repo
3359 my $seen_files = {};
3361 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3363 while ( <FILELIST> )
3366 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3368 die("Couldn't process git-ls-tree line : $_");
3371 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3373 $seen_files->{$git_filename} = 1;
3375 my ( $oldhash, $oldrevision, $oldmode ) = (
3376 $head->{$git_filename}{filehash},
3377 $head->{$git_filename}{revision},
3378 $head->{$git_filename}{mode}
3381 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3384 $git_perms .= "r" if ( $1 & 4 );
3385 $git_perms .= "w" if ( $1 & 2 );
3386 $git_perms .= "x" if ( $1 & 1 );
3391 # unless the file exists with the same hash, we need to update it ...
3392 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3394 my $newrevision = ( $oldrevision or 0 ) + 1;
3396 $head->{$git_filename} = {
3397 name => $git_filename,
3398 revision => $newrevision,
3399 filehash => $git_hash,
3400 commithash => $commit->{hash},
3401 modified => $commit->{date},
3402 author => $commit->{author},
3407 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3412 # Detect deleted files
3413 foreach my $file ( keys %$head )
3415 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3417 $head->{$file}{revision}++;
3418 $head->{$file}{filehash} = "deleted";
3419 $head->{$file}{commithash} = $commit->{hash};
3420 $head->{$file}{modified} = $commit->{date};
3421 $head->{$file}{author} = $commit->{author};
3423 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3426 # END : "Detect deleted files"
3430 if (exists $commit->{mergemsg})
3432 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3435 $lastpicked = $commit->{hash};
3437 $self->_set_prop("last_commit", $commit->{hash});
3440 $self->delete_head();
3441 foreach my $file ( keys %$head )
3445 $head->{$file}{revision},
3446 $head->{$file}{filehash},
3447 $head->{$file}{commithash},
3448 $head->{$file}{modified},
3449 $head->{$file}{author},
3450 $head->{$file}{mode},
3453 # invalidate the gethead cache
3454 $self->{gethead_cache} = undef;
3457 # Ending exclusive lock here
3458 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3465 my $revision = shift;
3466 my $filehash = shift;
3467 my $commithash = shift;
3468 my $modified = shift;
3471 my $tablename = $self->tablename("revision");
3473 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3474 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3482 my $tablename = $self->tablename("commitmsgs");
3484 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3485 $insert_mergelog->execute($key, $value);
3491 my $tablename = $self->tablename("head");
3493 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3494 $delete_head->execute();
3501 my $revision = shift;
3502 my $filehash = shift;
3503 my $commithash = shift;
3504 my $modified = shift;
3507 my $tablename = $self->tablename("head");
3509 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3510 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3517 my $tablename = $self->tablename("properties");
3519 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3520 $db_query->execute($key);
3521 my ( $value ) = $db_query->fetchrow_array;
3531 my $tablename = $self->tablename("properties");
3533 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3534 $db_query->execute($value, $key);
3536 unless ( $db_query->rows )
3538 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3539 $db_query->execute($key, $value);
3553 my $tablename = $self->tablename("head");
3555 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3557 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3558 $db_query->execute();
3561 while ( my $file = $db_query->fetchrow_hashref )
3565 $file->{revision} = "1.$file->{revision}"
3570 $self->{gethead_cache} = $tree;
3577 See also gethistorydense().
3584 my $filename = shift;
3585 my $revFilter = shift;
3587 my $tablename = $self->tablename("revision");
3590 # TODO: date, state, or by specific logins filters?
3591 # TODO: Handle comma-separated list of revFilter items, each item
3592 # can be a range [only case currently handled] or individual
3593 # rev or branch or "branch.".
3594 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
3595 # manually filtering the results of the query?
3596 my ( $minrev, $maxrev );
3597 if( defined($revFilter) and
3598 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
3603 $minrev++ if ( defined($minrev) and $control eq "::" );
3606 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3607 $db_query->execute($filename);
3611 while ( my $file = $db_query->fetchrow_hashref )
3614 if( defined($minrev) and $file->{revision} < $minrev )
3618 if( defined($maxrev) and $file->{revision} > $maxrev )
3623 $file->{revision} = "1." . $file->{revision};
3627 return ($tree,$totalRevs);
3632 This function takes a filename (with path) argument and returns a hashref of
3633 metadata for that file.
3640 my $filename = shift;
3641 my $revision = shift;
3642 my $tablename_rev = $self->tablename("revision");
3643 my $tablename_head = $self->tablename("head");
3646 if ( defined($revision) and $revision =~ /^1\.(\d+)$/ )
3649 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3650 $db_query->execute($filename, $intRev);
3652 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3654 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3655 $db_query->execute($filename, $revision);
3657 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3658 $db_query->execute($filename);
3661 my $meta = $db_query->fetchrow_hashref;
3664 $meta->{revision} = "1.$meta->{revision}";
3669 =head2 commitmessage
3671 this function takes a commithash and returns the commit message for that commit
3677 my $commithash = shift;
3678 my $tablename = $self->tablename("commitmsgs");
3680 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3683 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3684 $db_query->execute($commithash);
3686 my ( $message ) = $db_query->fetchrow_array;
3688 if ( defined ( $message ) )
3690 $message .= " " if ( $message =~ /\n$/ );
3694 my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3695 shift @lines while ( $lines[0] =~ /\S/ );
3696 $message = join("",@lines);
3697 $message .= " " if ( $message =~ /\n$/ );
3701 =head2 gethistorydense
3703 This function takes a filename (with path) argument and returns an arrayofarrays
3704 containing revision,filehash,commithash ordered by revision descending.
3706 This version of gethistory skips deleted entries -- so it is useful for annotate.
3707 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3708 and other git tools that depend on it.
3716 my $filename = shift;
3717 my $tablename = $self->tablename("revision");
3720 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3721 $db_query->execute($filename);
3723 my $result = $db_query->fetchall_arrayref;
3726 for($i=0 ; $i<scalar(@$result) ; $i++)
3728 $result->[$i][0]="1." . $result->[$i][0];
3736 from Array::PAT - mimics the in_array() function
3737 found in PHP. Yuck but works for small arrays.
3742 my ($check, @array) = @_;
3744 foreach my $test (@array){
3745 if($check eq $test){
3752 =head2 safe_pipe_capture
3754 an alternative to `command` that allows input to be passed as an array
3755 to work around shell problems with weird characters in arguments
3758 sub safe_pipe_capture {
3762 if (my $pid = open my $child, '-|') {
3763 @output = (<$child>);
3764 close $child or die join(' ',@_).": $! $?";
3766 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3768 return wantarray ? @output : join('',@output);
3771 =head2 mangle_dirname
3773 create a string from a directory name that is suitable to use as
3774 part of a filename, mainly by converting all chars except \w.- to _
3777 sub mangle_dirname {
3778 my $dirname = shift;
3779 return unless defined $dirname;
3781 $dirname =~ s/[^\w.-]/_/g;
3786 =head2 mangle_tablename
3788 create a string from a that is suitable to use as part of an SQL table
3789 name, mainly by converting all chars except \w to _
3792 sub mangle_tablename {
3793 my $tablename = shift;
3794 return unless defined $tablename;
3796 $tablename =~ s/[^\w_]/_/g;