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);
548 foreach my $filename ( @
{$state->{args
}} )
550 $filename = filecleanup
($filename);
552 my $meta = $updater->getmeta($filename);
553 my $wrev = revparse
($filename);
555 if ($wrev && $meta && ($wrev=~/^-/))
557 # previously removed file, add back
558 $log->info("added file $filename was previously removed, send $meta->{revision}");
560 print "MT +updated\n";
561 print "MT text U \n";
562 print "MT fname $filename\n";
563 print "MT newline\n";
564 print "MT -updated\n";
566 unless ( $state->{globaloptions
}{-n
} )
568 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
570 print "Created $dirpart\n";
571 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
573 # this is an "entries" line
574 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
575 $log->debug("/$filepart/$meta->{revision}//$kopts/");
576 print "/$filepart/$meta->{revision}//$kopts/\n";
578 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
579 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
581 transmitfile
($meta->{filehash
});
587 unless ( defined ( $state->{entries
}{$filename}{modified_filename
} ) )
589 print "E cvs add: nothing known about `$filename'\n";
592 # TODO : check we're not squashing an already existing file
593 if ( defined ( $state->{entries
}{$filename}{revision
} ) )
595 print "E cvs add: `$filename' has already been entered\n";
599 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
601 print "E cvs add: scheduling file `$filename' for addition\n";
603 print "Checked-in $dirpart\n";
605 my $kopts = kopts_from_path
($filename,"file",
606 $state->{entries
}{$filename}{modified_filename
});
607 print "/$filepart/0//$kopts/\n";
609 my $requestedKopts = $state->{opt
}{k
};
610 if(defined($requestedKopts))
612 $requestedKopts = "-k$requestedKopts";
616 $requestedKopts = "";
618 if( $kopts ne $requestedKopts )
620 $log->warn("Ignoring requested -k='$requestedKopts'"
621 . " for '$filename'; detected -k='$kopts' instead");
622 #TODO: Also have option to send warning to user?
628 if ( $addcount == 1 )
630 print "E cvs add: use `cvs commit' to add this file permanently\n";
632 elsif ( $addcount > 1 )
634 print "E cvs add: use `cvs commit' to add these files permanently\n";
641 # Response expected: yes. Remove a file. This uses any previous Argument,
642 # Directory, Entry, or Modified requests, if they have been sent. The last
643 # Directory sent specifies the working directory at the time of the
644 # operation. Note that this request does not actually do anything to the
645 # repository; the only effect of a successful remove request is to supply
646 # the client with a new entries line containing `-' to indicate a removed
647 # file. In fact, the client probably could perform this operation without
648 # contacting the server, although using remove may cause the server to
649 # perform a few more checks. The client sends a subsequent ci request to
650 # actually record the removal in the repository.
653 my ( $cmd, $data ) = @_;
657 # Grab a handle to the SQLite db and do any necessary updates
658 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
661 #$log->debug("add state : " . Dumper($state));
665 foreach my $filename ( @
{$state->{args
}} )
667 $filename = filecleanup
($filename);
669 if ( defined ( $state->{entries
}{$filename}{unchanged
} ) or defined ( $state->{entries
}{$filename}{modified_filename
} ) )
671 print "E cvs remove: file `$filename' still in working directory\n";
675 my $meta = $updater->getmeta($filename);
676 my $wrev = revparse
($filename);
678 unless ( defined ( $wrev ) )
680 print "E cvs remove: nothing known about `$filename'\n";
684 if ( defined($wrev) and ($wrev=~/^-/) )
686 print "E cvs remove: file `$filename' already scheduled for removal\n";
690 unless ( $wrev eq $meta->{revision
} )
692 # TODO : not sure if the format of this message is quite correct.
693 print "E cvs remove: Up to date check failed for `$filename'\n";
698 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
700 print "E cvs remove: scheduling `$filename' for removal\n";
702 print "Checked-in $dirpart\n";
704 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
705 print "/$filepart/-$wrev//$kopts/\n";
712 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
714 elsif ( $rmcount > 1 )
716 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
722 # Modified filename \n
723 # Response expected: no. Additional data: mode, \n, file transmission. Send
724 # the server a copy of one locally modified file. filename is a file within
725 # the most recent directory sent with Directory; it must not contain `/'.
726 # If the user is operating on only some files in a directory, only those
727 # files need to be included. This can also be sent without Entry, if there
728 # is no entry for the file.
731 my ( $cmd, $data ) = @_;
735 or (print "E end of file reading mode for $data\n"), return;
739 or (print "E end of file reading size of $data\n"), return;
742 # Grab config information
743 my $blocksize = 8192;
744 my $bytesleft = $size;
747 # Get a filehandle/name to write it to
748 my ( $fh, $filename ) = tempfile
( DIR
=> $TEMP_DIR );
750 # Loop over file data writing out to temporary file.
753 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
754 read STDIN
, $tmp, $blocksize;
756 $bytesleft -= $blocksize;
760 or (print "E failed to write temporary, $filename: $!\n"), return;
762 # Ensure we have something sensible for the file mode
763 if ( $mode =~ /u=(\w+)/ )
770 # Save the file data in $state
771 $state->{entries
}{$state->{directory
}.$data}{modified_filename
} = $filename;
772 $state->{entries
}{$state->{directory
}.$data}{modified_mode
} = $mode;
773 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} = `git hash-object $filename`;
774 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} =~ s/\s.*$//s;
776 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
779 # Unchanged filename \n
780 # Response expected: no. Tell the server that filename has not been
781 # modified in the checked out directory. The filename is a file within the
782 # most recent directory sent with Directory; it must not contain `/'.
785 my ( $cmd, $data ) = @_;
787 $state->{entries
}{$state->{directory
}.$data}{unchanged
} = 1;
789 #$log->debug("req_Unchanged : $data");
793 # Response expected: no. Save argument for use in a subsequent command.
794 # Arguments accumulate until an argument-using command is given, at which
795 # point they are forgotten.
797 # Response expected: no. Append \n followed by text to the current argument
801 my ( $cmd, $data ) = @_;
803 # Argumentx means: append to last Argument (with a newline in front)
805 $log->debug("$cmd : $data");
807 if ( $cmd eq 'Argumentx') {
808 ${$state->{arguments
}}[$#{$state->{arguments}}] .= "\n" . $data;
810 push @
{$state->{arguments
}}, $data;
815 # Response expected: yes. Expand the modules which are specified in the
816 # arguments. Returns the data in Module-expansion responses. Note that the
817 # server can assume that this is checkout or export, not rtag or rdiff; the
818 # latter do not access the working directory and thus have no need to
819 # expand modules on the client side. Expand may not be the best word for
820 # what this request does. It does not necessarily tell you all the files
821 # contained in a module, for example. Basically it is a way of telling you
822 # which working directories the server needs to know about in order to
823 # handle a checkout of the specified modules. For example, suppose that the
824 # server has a module defined by
825 # aliasmodule -a 1dir
826 # That is, one can check out aliasmodule and it will take 1dir in the
827 # repository and check it out to 1dir in the working directory. Now suppose
828 # the client already has this module checked out and is planning on using
829 # the co request to update it. Without using expand-modules, the client
830 # would have two bad choices: it could either send information about all
831 # working directories under the current directory, which could be
832 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
833 # stands for 1dir, and neglect to send information for 1dir, which would
834 # lead to incorrect operation. With expand-modules, the client would first
835 # ask for the module to be expanded:
836 sub req_expandmodules
838 my ( $cmd, $data ) = @_;
842 $log->debug("req_expandmodules : " . ( defined($data) ?
$data : "[NULL]" ) );
844 unless ( ref $state->{arguments
} eq "ARRAY" )
850 foreach my $module ( @
{$state->{arguments
}} )
852 $log->debug("SEND : Module-expansion $module");
853 print "Module-expansion $module\n";
861 # Response expected: yes. Get files from the repository. This uses any
862 # previous Argument, Directory, Entry, or Modified requests, if they have
863 # been sent. Arguments to this command are module names; the client cannot
864 # know what directories they correspond to except by (1) just sending the
865 # co request, and then seeing what directory names the server sends back in
866 # its responses, and (2) the expand-modules request.
869 my ( $cmd, $data ) = @_;
873 # Provide list of modules, if -c was used.
874 if (exists $state->{opt
}{c
}) {
875 my $showref = `git show-ref --heads`;
876 for my $line (split '\n', $showref) {
877 if ( $line =~ m
% refs
/heads/(.*)$% ) {
885 my $module = $state->{args
}[0];
886 $state->{module
} = $module;
887 my $checkout_path = $module;
889 # use the user specified directory if we're given it
890 $checkout_path = $state->{opt
}{d
} if ( exists ( $state->{opt
}{d
} ) );
892 $log->debug("req_co : " . ( defined($data) ?
$data : "[NULL]" ) );
894 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
896 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
898 # Grab a handle to the SQLite db and do any necessary updates
899 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $module, $log);
902 $checkout_path =~ s
|/$||; # get rid of trailing slashes
904 # Eclipse seems to need the Clear-sticky command
905 # to prepare the 'Entries' file for the new directory.
906 print "Clear-sticky $checkout_path/\n";
907 print $state->{CVSROOT
} . "/$module/\n";
908 print "Clear-static-directory $checkout_path/\n";
909 print $state->{CVSROOT
} . "/$module/\n";
910 print "Clear-sticky $checkout_path/\n"; # yes, twice
911 print $state->{CVSROOT
} . "/$module/\n";
912 print "Template $checkout_path/\n";
913 print $state->{CVSROOT
} . "/$module/\n";
916 # instruct the client that we're checking out to $checkout_path
917 print "E cvs checkout: Updating $checkout_path\n";
924 my ($dir, $repodir, $remotedir, $seendirs) = @_;
925 my $parent = dirname
($dir);
928 $remotedir =~ s
|/+$||;
930 $log->debug("announcedir $dir, $repodir, $remotedir" );
932 if ($parent eq '.' || $parent eq './') {
935 # recurse to announce unseen parents first
936 if (length($parent) && !exists($seendirs->{$parent})) {
937 prepdir
($parent, $repodir, $remotedir, $seendirs);
939 # Announce that we are going to modify at the parent level
941 print "E cvs checkout: Updating $remotedir/$parent\n";
943 print "E cvs checkout: Updating $remotedir\n";
945 print "Clear-sticky $remotedir/$parent/\n";
946 print "$repodir/$parent/\n";
948 print "Clear-static-directory $remotedir/$dir/\n";
949 print "$repodir/$dir/\n";
950 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
951 print "$repodir/$parent/\n";
952 print "Template $remotedir/$dir/\n";
953 print "$repodir/$dir/\n";
956 $seendirs->{$dir} = 1;
959 foreach my $git ( @
{$updater->gethead} )
961 # Don't want to check out deleted files
962 next if ( $git->{filehash
} eq "deleted" );
964 my $fullName = $git->{name
};
965 ( $git->{name
}, $git->{dir
} ) = filenamesplit
($git->{name
});
967 if (length($git->{dir
}) && $git->{dir
} ne './'
968 && $git->{dir
} ne $lastdir ) {
969 unless (exists($seendirs{$git->{dir
}})) {
970 prepdir
($git->{dir
}, $state->{CVSROOT
} . "/$module/",
971 $checkout_path, \
%seendirs);
972 $lastdir = $git->{dir
};
973 $seendirs{$git->{dir
}} = 1;
975 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
978 # modification time of this file
979 print "Mod-time $git->{modified}\n";
981 # print some information to the client
982 if ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" )
984 print "M U $checkout_path/$git->{dir}$git->{name}\n";
986 print "M U $checkout_path/$git->{name}\n";
989 # instruct client we're sending a file to put in this path
990 print "Created $checkout_path/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "\n";
992 print $state->{CVSROOT
} . "/$module/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "$git->{name}\n";
994 # this is an "entries" line
995 my $kopts = kopts_from_path
($fullName,"sha1",$git->{filehash
});
996 print "/$git->{name}/$git->{revision}//$kopts/\n";
998 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1001 transmitfile
($git->{filehash
});
1010 # Response expected: yes. Actually do a cvs update command. This uses any
1011 # previous Argument, Directory, Entry, or Modified requests, if they have
1012 # been sent. The last Directory sent specifies the working directory at the
1013 # time of the operation. The -I option is not used--files which the client
1014 # can decide whether to ignore are not mentioned and the client sends the
1015 # Questionable request for others.
1018 my ( $cmd, $data ) = @_;
1020 $log->debug("req_update : " . ( defined($data) ?
$data : "[NULL]" ));
1025 # It may just be a client exploring the available heads/modules
1026 # in that case, list them as top level directories and leave it
1027 # at that. Eclipse uses this technique to offer you a list of
1028 # projects (heads in this case) to checkout.
1030 if ($state->{module
} eq '') {
1031 my $showref = `git show-ref --heads`;
1032 print "E cvs update: Updating .\n";
1033 for my $line (split '\n', $showref) {
1034 if ( $line =~ m
% refs
/heads/(.*)$% ) {
1035 print "E cvs update: New directory `$1'\n";
1043 # Grab a handle to the SQLite db and do any necessary updates
1044 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1048 argsfromdir
($updater);
1050 #$log->debug("update state : " . Dumper($state));
1052 my $last_dirname = "///";
1054 # foreach file specified on the command line ...
1055 foreach my $filename ( @
{$state->{args
}} )
1057 $filename = filecleanup
($filename);
1059 $log->debug("Processing file $filename");
1061 unless ( $state->{globaloptions
}{-Q
} || $state->{globaloptions
}{-q
} )
1063 my $cur_dirname = dirname
($filename);
1064 if ( $cur_dirname ne $last_dirname )
1066 $last_dirname = $cur_dirname;
1067 if ( $cur_dirname eq "" )
1071 print "E cvs update: Updating $cur_dirname\n";
1075 # if we have a -C we should pretend we never saw modified stuff
1076 if ( exists ( $state->{opt
}{C
} ) )
1078 delete $state->{entries
}{$filename}{modified_hash
};
1079 delete $state->{entries
}{$filename}{modified_filename
};
1080 $state->{entries
}{$filename}{unchanged
} = 1;
1084 if ( defined($state->{opt
}{r
}) and $state->{opt
}{r
} =~ /^(1\.\d+)$/ )
1086 $meta = $updater->getmeta($filename, $1);
1088 $meta = $updater->getmeta($filename);
1091 # If -p was given, "print" the contents of the requested revision.
1092 if ( exists ( $state->{opt
}{p
} ) ) {
1093 if ( defined ( $meta->{revision
} ) ) {
1094 $log->info("Printing '$filename' revision " . $meta->{revision
});
1096 transmitfile
($meta->{filehash
}, { print => 1 });
1102 if ( ! defined $meta )
1111 my $oldmeta = $meta;
1113 my $wrev = revparse
($filename);
1115 # If the working copy is an old revision, lets get that version too for comparison.
1116 if ( defined($wrev) and $wrev ne $meta->{revision
} )
1118 $oldmeta = $updater->getmeta($filename, $wrev);
1121 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1123 # Files are up to date if the working copy and repo copy have the same revision,
1124 # and the working copy is unmodified _and_ the user hasn't specified -C
1125 next if ( defined ( $wrev )
1126 and defined($meta->{revision
})
1127 and $wrev eq $meta->{revision
}
1128 and $state->{entries
}{$filename}{unchanged
}
1129 and not exists ( $state->{opt
}{C
} ) );
1131 # If the working copy and repo copy have the same revision,
1132 # but the working copy is modified, tell the client it's modified
1133 if ( defined ( $wrev )
1134 and defined($meta->{revision
})
1135 and $wrev eq $meta->{revision
}
1136 and defined($state->{entries
}{$filename}{modified_hash
})
1137 and not exists ( $state->{opt
}{C
} ) )
1139 $log->info("Tell the client the file is modified");
1140 print "MT text M \n";
1141 print "MT fname $filename\n";
1142 print "MT newline\n";
1146 if ( $meta->{filehash
} eq "deleted" )
1148 # TODO: If it has been modified in the sandbox, error out
1149 # with the appropriate message, rather than deleting a modified
1152 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1154 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1156 print "E cvs update: `$filename' is no longer in the repository\n";
1157 # Don't want to actually _DO_ the update if -n specified
1158 unless ( $state->{globaloptions
}{-n
} ) {
1159 print "Removed $dirpart\n";
1160 print "$filepart\n";
1163 elsif ( not defined ( $state->{entries
}{$filename}{modified_hash
} )
1164 or $state->{entries
}{$filename}{modified_hash
} eq $oldmeta->{filehash
}
1165 or $meta->{filehash
} eq 'added' )
1167 # normal update, just send the new revision (either U=Update,
1168 # or A=Add, or R=Remove)
1169 if ( defined($wrev) && ($wrev=~/^-/) )
1171 $log->info("Tell the client the file is scheduled for removal");
1172 print "MT text R \n";
1173 print "MT fname $filename\n";
1174 print "MT newline\n";
1177 elsif ( (!defined($wrev) || $wrev eq '0') &&
1178 (!defined($meta->{revision
}) || $meta->{revision
} eq '0') )
1180 $log->info("Tell the client the file is scheduled for addition");
1181 print "MT text A \n";
1182 print "MT fname $filename\n";
1183 print "MT newline\n";
1188 $log->info("UpdatingX3 '$filename' to ".$meta->{revision
});
1189 print "MT +updated\n";
1190 print "MT text U \n";
1191 print "MT fname $filename\n";
1192 print "MT newline\n";
1193 print "MT -updated\n";
1196 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1198 # Don't want to actually _DO_ the update if -n specified
1199 unless ( $state->{globaloptions
}{-n
} )
1201 if ( defined ( $wrev ) )
1203 # instruct client we're sending a file to put in this path as a replacement
1204 print "Update-existing $dirpart\n";
1205 $log->debug("Updating existing file 'Update-existing $dirpart'");
1207 # instruct client we're sending a file to put in this path as a new file
1208 print "Clear-static-directory $dirpart\n";
1209 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
1210 print "Clear-sticky $dirpart\n";
1211 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
1213 $log->debug("Creating new file 'Created $dirpart'");
1214 print "Created $dirpart\n";
1216 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1218 # this is an "entries" line
1219 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1220 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1221 print "/$filepart/$meta->{revision}//$kopts/\n";
1224 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1225 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1228 transmitfile
($meta->{filehash
});
1231 my ( $filepart, $dirpart ) = filenamesplit
($meta->{name
},1);
1233 my $mergeDir = setupTmpDir
();
1235 my $file_local = $filepart . ".mine";
1236 my $mergedFile = "$mergeDir/$file_local";
1237 system("ln","-s",$state->{entries
}{$filename}{modified_filename
}, $file_local);
1238 my $file_old = $filepart . "." . $oldmeta->{revision
};
1239 transmitfile
($oldmeta->{filehash
}, { targetfile
=> $file_old });
1240 my $file_new = $filepart . "." . $meta->{revision
};
1241 transmitfile
($meta->{filehash
}, { targetfile
=> $file_new });
1243 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1244 $log->info("Merging $file_local, $file_old, $file_new");
1245 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1247 $log->debug("Temporary directory for merge is $mergeDir");
1249 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1256 $log->info("Merged successfully");
1257 print "M M $filename\n";
1258 $log->debug("Merged $dirpart");
1260 # Don't want to actually _DO_ the update if -n specified
1261 unless ( $state->{globaloptions
}{-n
} )
1263 print "Merged $dirpart\n";
1264 $log->debug($state->{CVSROOT
} . "/$state->{module}/$filename");
1265 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1266 my $kopts = kopts_from_path
("$dirpart/$filepart",
1267 "file",$mergedFile);
1268 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1269 print "/$filepart/$meta->{revision}//$kopts/\n";
1272 elsif ( $return == 1 )
1274 $log->info("Merged with conflicts");
1275 print "E cvs update: conflicts found in $filename\n";
1276 print "M C $filename\n";
1278 # Don't want to actually _DO_ the update if -n specified
1279 unless ( $state->{globaloptions
}{-n
} )
1281 print "Merged $dirpart\n";
1282 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1283 my $kopts = kopts_from_path
("$dirpart/$filepart",
1284 "file",$mergedFile);
1285 print "/$filepart/$meta->{revision}/+/$kopts/\n";
1290 $log->warn("Merge failed");
1294 # Don't want to actually _DO_ the update if -n specified
1295 unless ( $state->{globaloptions
}{-n
} )
1298 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1299 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1301 # transmit file, format is single integer on a line by itself (file
1302 # size) followed by the file contents
1303 # TODO : we should copy files in blocks
1304 my $data = `cat $mergedFile`;
1305 $log->debug("File size : " . length($data));
1306 print length($data) . "\n";
1318 my ( $cmd, $data ) = @_;
1322 #$log->debug("State : " . Dumper($state));
1324 $log->info("req_ci : " . ( defined($data) ?
$data : "[NULL]" ));
1326 if ( $state->{method
} eq 'pserver' and $state->{user
} eq 'anonymous' )
1328 print "error 1 anonymous user cannot commit via pserver\n";
1333 if ( -e
$state->{CVSROOT
} . "/index" )
1335 $log->warn("file 'index' already exists in the git repository");
1336 print "error 1 Index already exists in git repo\n";
1341 # Grab a handle to the SQLite db and do any necessary updates
1342 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1345 # Remember where the head was at the beginning.
1346 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1348 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1349 print "error 1 pserver cannot find the current HEAD of module";
1354 setupWorkTree
($parenthash);
1356 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1358 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1360 my @committedfiles = ();
1363 # foreach file specified on the command line ...
1364 foreach my $filename ( @
{$state->{args
}} )
1366 my $committedfile = $filename;
1367 $filename = filecleanup
($filename);
1369 next unless ( exists $state->{entries
}{$filename}{modified_filename
} or not $state->{entries
}{$filename}{unchanged
} );
1371 my $meta = $updater->getmeta($filename);
1372 $oldmeta{$filename} = $meta;
1374 my $wrev = revparse
($filename);
1376 my ( $filepart, $dirpart ) = filenamesplit
($filename);
1378 # do a checkout of the file if it is part of this tree
1380 system('git', 'checkout-index', '-f', '-u', $filename);
1382 die "Error running git-checkout-index -f -u $filename : $!";
1388 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1389 $addflag = 1 unless ( -e
$filename );
1391 # Do up to date checking
1392 unless ( $addflag or $wrev eq $meta->{revision
} or
1393 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1395 # fail everything if an up to date check fails
1396 print "error 1 Up to date check failed for $filename\n";
1401 push @committedfiles, $committedfile;
1402 $log->info("Committing $filename");
1404 system("mkdir","-p",$dirpart) unless ( -d
$dirpart );
1408 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1409 rename $state->{entries
}{$filename}{modified_filename
},$filename;
1411 # Calculate modes to remove
1413 foreach ( qw
(r w x
) ) { $invmode .= $_ unless ( $state->{entries
}{$filename}{modified_mode
} =~ /$_/ ); }
1415 $log->debug("chmod u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode . " $filename");
1416 system("chmod","u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode, $filename);
1421 $log->info("Removing file '$filename'");
1423 system("git", "update-index", "--remove", $filename);
1427 $log->info("Adding file '$filename'");
1428 system("git", "update-index", "--add", $filename);
1430 $log->info("UpdatingX2 file '$filename'");
1431 system("git", "update-index", $filename);
1435 unless ( scalar(@committedfiles) > 0 )
1437 print "E No files to commit\n";
1443 my $treehash = `git write-tree`;
1446 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1448 # write our commit message out if we have one ...
1449 my ( $msg_fh, $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1450 print $msg_fh $state->{opt
}{m
};# if ( exists ( $state->{opt}{m} ) );
1451 if ( defined ( $cfg->{gitcvs
}{commitmsgannotation
} ) ) {
1452 if ($cfg->{gitcvs
}{commitmsgannotation
} !~ /^\s*$/ ) {
1453 print $msg_fh "\n\n".$cfg->{gitcvs
}{commitmsgannotation
}."\n"
1456 print $msg_fh "\n\nvia git-CVS emulator\n";
1460 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1462 $log->info("Commit hash : $commithash");
1464 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1466 $log->warn("Commit failed (Invalid commit hash)");
1467 print "error 1 Commit failed (unknown reason)\n";
1472 ### Emulate git-receive-pack by running hooks/update
1473 my @hook = ( $ENV{GIT_DIR
}.'hooks/update', "refs/heads/$state->{module}",
1474 $parenthash, $commithash );
1476 unless( system( @hook ) == 0 )
1478 $log->warn("Commit failed (update hook declined to update ref)");
1479 print "error 1 Commit failed (update hook declined)\n";
1486 if (system(qw(git update-ref -m), "cvsserver ci",
1487 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1488 $log->warn("update-ref for $state->{module} failed.");
1489 print "error 1 Cannot commit -- update first\n";
1494 ### Emulate git-receive-pack by running hooks/post-receive
1495 my $hook = $ENV{GIT_DIR
}.'hooks/post-receive';
1497 open(my $pipe, "| $hook") || die "can't fork $!";
1499 local $SIG{PIPE
} = sub { die 'pipe broke' };
1501 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1503 close $pipe || die "bad pipe: $! $?";
1508 ### Then hooks/post-update
1509 $hook = $ENV{GIT_DIR
}.'hooks/post-update';
1511 system($hook, "refs/heads/$state->{module}");
1514 # foreach file specified on the command line ...
1515 foreach my $filename ( @committedfiles )
1517 $filename = filecleanup
($filename);
1519 my $meta = $updater->getmeta($filename);
1520 unless (defined $meta->{revision
}) {
1521 $meta->{revision
} = "1.1";
1524 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
1526 $log->debug("Checked-in $dirpart : $filename");
1528 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1529 if ( defined $meta->{filehash
} && $meta->{filehash
} eq "deleted" )
1531 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1532 print "Remove-entry $dirpart\n";
1533 print "$filename\n";
1535 if ($meta->{revision
} eq "1.1") {
1536 print "M initial revision: 1.1\n";
1538 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1540 print "Checked-in $dirpart\n";
1541 print "$filename\n";
1542 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1543 print "/$filepart/$meta->{revision}//$kopts/\n";
1553 my ( $cmd, $data ) = @_;
1557 $log->info("req_status : " . ( defined($data) ?
$data : "[NULL]" ));
1558 #$log->debug("status state : " . Dumper($state));
1560 # Grab a handle to the SQLite db and do any necessary updates
1562 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1565 # if no files were specified, we need to work out what files we should
1566 # be providing status on ...
1567 argsfromdir
($updater);
1569 # foreach file specified on the command line ...
1570 foreach my $filename ( @
{$state->{args
}} )
1572 $filename = filecleanup
($filename);
1574 if ( exists($state->{opt
}{l
}) &&
1575 index($filename, '/', length($state->{prependdir
})) >= 0 )
1580 my $meta = $updater->getmeta($filename);
1581 my $oldmeta = $meta;
1583 my $wrev = revparse
($filename);
1585 # If the working copy is an old revision, lets get that
1586 # version too for comparison.
1587 if ( defined($wrev) and $wrev ne $meta->{revision
} )
1589 $oldmeta = $updater->getmeta($filename, $wrev);
1592 # TODO : All possible statuses aren't yet implemented
1594 # Files are up to date if the working copy and repo copy have
1595 # the same revision, and the working copy is unmodified
1596 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1597 $wrev eq $meta->{revision
} and
1598 ( ( $state->{entries
}{$filename}{unchanged
} and
1599 ( not defined ( $state->{entries
}{$filename}{conflict
} ) or
1600 $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) ) or
1601 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1602 $state->{entries
}{$filename}{modified_hash
} eq
1603 $meta->{filehash
} ) ) )
1605 $status = "Up-to-date"
1608 # Need checkout if the working copy has a different (usually
1609 # older) revision than the repo copy, and the working copy is
1611 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1612 $meta->{revision
} ne $wrev and
1613 ( $state->{entries
}{$filename}{unchanged
} or
1614 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1615 $state->{entries
}{$filename}{modified_hash
} eq
1616 $oldmeta->{filehash
} ) ) )
1618 $status ||= "Needs Checkout";
1621 # Need checkout if it exists in the repo but doesn't have a working
1623 if ( not defined ( $wrev ) and defined ( $meta->{revision
} ) )
1625 $status ||= "Needs Checkout";
1628 # Locally modified if working copy and repo copy have the
1629 # same revision but there are local changes
1630 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1631 $wrev eq $meta->{revision
} and
1632 $state->{entries
}{$filename}{modified_filename
} )
1634 $status ||= "Locally Modified";
1637 # Needs Merge if working copy revision is different
1638 # (usually older) than repo copy and there are local changes
1639 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1640 $meta->{revision
} ne $wrev and
1641 $state->{entries
}{$filename}{modified_filename
} )
1643 $status ||= "Needs Merge";
1646 if ( defined ( $state->{entries
}{$filename}{revision
} ) and
1647 not defined ( $meta->{revision
} ) )
1649 $status ||= "Locally Added";
1651 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1652 $wrev eq "-$meta->{revision}" )
1654 $status ||= "Locally Removed";
1656 if ( defined ( $state->{entries
}{$filename}{conflict
} ) and
1657 $state->{entries
}{$filename}{conflict
} =~ /^\+=/ )
1659 $status ||= "Unresolved Conflict";
1663 $status ||= "File had conflicts on merge";
1666 $status ||= "Unknown";
1668 my ($filepart) = filenamesplit
($filename);
1670 print "M =======" . ( "=" x
60 ) . "\n";
1671 print "M File: $filepart\tStatus: $status\n";
1672 if ( defined($state->{entries
}{$filename}{revision
}) )
1674 print "M Working revision:\t" .
1675 $state->{entries
}{$filename}{revision
} . "\n";
1677 print "M Working revision:\tNo entry for $filename\n";
1679 if ( defined($meta->{revision
}) )
1681 print "M Repository revision:\t" .
1683 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1684 print "M Sticky Tag:\t\t(none)\n";
1685 print "M Sticky Date:\t\t(none)\n";
1686 print "M Sticky Options:\t\t(none)\n";
1688 print "M Repository revision:\tNo revision control file\n";
1698 my ( $cmd, $data ) = @_;
1702 $log->debug("req_diff : " . ( defined($data) ?
$data : "[NULL]" ));
1703 #$log->debug("status state : " . Dumper($state));
1705 my ($revision1, $revision2);
1706 if ( defined ( $state->{opt
}{r
} ) and ref $state->{opt
}{r
} eq "ARRAY" )
1708 $revision1 = $state->{opt
}{r
}[0];
1709 $revision2 = $state->{opt
}{r
}[1];
1711 $revision1 = $state->{opt
}{r
};
1714 $log->debug("Diffing revisions " .
1715 ( defined($revision1) ?
$revision1 : "[NULL]" ) .
1716 " and " . ( defined($revision2) ?
$revision2 : "[NULL]" ) );
1718 # Grab a handle to the SQLite db and do any necessary updates
1720 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1723 # if no files were specified, we need to work out what files we should
1724 # be providing status on ...
1725 argsfromdir
($updater);
1727 # foreach file specified on the command line ...
1728 foreach my $filename ( @
{$state->{args
}} )
1730 $filename = filecleanup
($filename);
1732 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1734 my $wrev = revparse
($filename);
1736 # We need _something_ to diff against
1737 next unless ( defined ( $wrev ) );
1739 # if we have a -r switch, use it
1740 if ( defined ( $revision1 ) )
1742 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1743 $meta1 = $updater->getmeta($filename, $revision1);
1744 unless ( defined ( $meta1 ) and $meta1->{filehash
} ne "deleted" )
1746 print "E File $filename at revision $revision1 doesn't exist\n";
1749 transmitfile
($meta1->{filehash
}, { targetfile
=> $file1 });
1751 # otherwise we just use the working copy revision
1754 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1755 $meta1 = $updater->getmeta($filename, $wrev);
1756 transmitfile
($meta1->{filehash
}, { targetfile
=> $file1 });
1759 # if we have a second -r switch, use it too
1760 if ( defined ( $revision2 ) )
1762 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1763 $meta2 = $updater->getmeta($filename, $revision2);
1765 unless ( defined ( $meta2 ) and $meta2->{filehash
} ne "deleted" )
1767 print "E File $filename at revision $revision2 doesn't exist\n";
1771 transmitfile
($meta2->{filehash
}, { targetfile
=> $file2 });
1773 # otherwise we just use the working copy
1776 $file2 = $state->{entries
}{$filename}{modified_filename
};
1779 # if we have been given -r, and we don't have a $file2 yet, lets
1781 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1783 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1784 $meta2 = $updater->getmeta($filename, $wrev);
1785 transmitfile
($meta2->{filehash
}, { targetfile
=> $file2 });
1788 # We need to have retrieved something useful
1789 next unless ( defined ( $meta1 ) );
1791 # Files to date if the working copy and repo copy have the same
1792 # revision, and the working copy is unmodified
1793 if ( not defined ( $meta2 ) and $wrev eq $meta1->{revision
} and
1794 ( ( $state->{entries
}{$filename}{unchanged
} and
1795 ( not defined ( $state->{entries
}{$filename}{conflict
} ) or
1796 $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) ) or
1797 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1798 $state->{entries
}{$filename}{modified_hash
} eq
1799 $meta1->{filehash
} ) ) )
1804 # Apparently we only show diffs for locally modified files
1805 unless ( defined($meta2) or
1806 defined ( $state->{entries
}{$filename}{modified_filename
} ) )
1811 print "M Index: $filename\n";
1812 print "M =======" . ( "=" x
60 ) . "\n";
1813 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1814 if ( defined ( $meta1 ) )
1816 print "M retrieving revision $meta1->{revision}\n"
1818 if ( defined ( $meta2 ) )
1820 print "M retrieving revision $meta2->{revision}\n"
1823 foreach my $opt ( keys %{$state->{opt
}} )
1825 if ( ref $state->{opt
}{$opt} eq "ARRAY" )
1827 foreach my $value ( @
{$state->{opt
}{$opt}} )
1829 print "-$opt $value ";
1833 if ( defined ( $state->{opt
}{$opt} ) )
1835 print "$state->{opt}{$opt} "
1839 print "$filename\n";
1841 $log->info("Diffing $filename -r $meta1->{revision} -r " .
1842 ( $meta2->{revision
} or "workingcopy" ));
1844 ( $fh, $filediff ) = tempfile
( DIR
=> $TEMP_DIR );
1846 if ( exists $state->{opt
}{u
} )
1848 system("diff -u -L '$filename revision $meta1->{revision}'" .
1850 ( defined($meta2->{revision
}) ?
1851 "revision $meta2->{revision}" :
1853 "' $file1 $file2 > $filediff" );
1855 system("diff $file1 $file2 > $filediff");
1870 my ( $cmd, $data ) = @_;
1874 $log->debug("req_log : " . ( defined($data) ?
$data : "[NULL]" ));
1875 #$log->debug("log state : " . Dumper($state));
1878 if ( defined ( $state->{opt
}{r
} ) )
1880 $revFilter = $state->{opt
}{r
};
1883 # Grab a handle to the SQLite db and do any necessary updates
1885 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1888 # if no files were specified, we need to work out what files we
1889 # should be providing status on ...
1890 argsfromdir
($updater);
1892 # foreach file specified on the command line ...
1893 foreach my $filename ( @
{$state->{args
}} )
1895 $filename = filecleanup
($filename);
1897 my $headmeta = $updater->getmeta($filename);
1899 my ($revisions,$totalrevisions) = $updater->getlog($filename,
1902 next unless ( scalar(@
$revisions) );
1905 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1906 print "M Working file: $filename\n";
1907 print "M head: $headmeta->{revision}\n";
1908 print "M branch:\n";
1909 print "M locks: strict\n";
1910 print "M access list:\n";
1911 print "M symbolic names:\n";
1912 print "M keyword substitution: kv\n";
1913 print "M total revisions: $totalrevisions;\tselected revisions: " .
1914 scalar(@
$revisions) . "\n";
1915 print "M description:\n";
1917 foreach my $revision ( @
$revisions )
1919 print "M ----------------------------\n";
1920 print "M revision $revision->{revision}\n";
1921 # reformat the date for log output
1922 if ( $revision->{modified
} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
1923 defined($DATE_LIST->{$2}) )
1925 $revision->{modified
} = sprintf('%04d/%02d/%02d %s',
1926 $3, $DATE_LIST->{$2}, $1, $4 );
1928 $revision->{author
} = cvs_author
($revision->{author
});
1929 print "M date: $revision->{modified};" .
1930 " author: $revision->{author}; state: " .
1931 ( $revision->{filehash
} eq "deleted" ?
"dead" : "Exp" ) .
1934 $commitmessage = $updater->commitmessage($revision->{commithash
});
1935 $commitmessage =~ s/^/M /mg;
1936 print $commitmessage . "\n";
1938 print "M =======" . ( "=" x
70 ) . "\n";
1946 my ( $cmd, $data ) = @_;
1948 argsplit
("annotate");
1950 $log->info("req_annotate : " . ( defined($data) ?
$data : "[NULL]" ));
1951 #$log->debug("status state : " . Dumper($state));
1953 # Grab a handle to the SQLite db and do any necessary updates
1954 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1957 # if no files were specified, we need to work out what files we should be providing annotate on ...
1958 argsfromdir
($updater);
1960 # we'll need a temporary checkout dir
1963 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1965 # foreach file specified on the command line ...
1966 foreach my $filename ( @
{$state->{args
}} )
1968 $filename = filecleanup
($filename);
1970 my $meta = $updater->getmeta($filename);
1972 next unless ( $meta->{revision
} );
1974 # get all the commits that this file was in
1975 # in dense format -- aka skip dead revisions
1976 my $revisions = $updater->gethistorydense($filename);
1977 my $lastseenin = $revisions->[0][2];
1979 # populate the temporary index based on the latest commit were we saw
1980 # the file -- but do it cheaply without checking out any files
1981 # TODO: if we got a revision from the client, use that instead
1982 # to look up the commithash in sqlite (still good to default to
1983 # the current head as we do now)
1984 system("git", "read-tree", $lastseenin);
1987 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1990 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1992 # do a checkout of the file
1993 system('git', 'checkout-index', '-f', '-u', $filename);
1995 print "E error running git-checkout-index -f -u $filename : $!\n";
1999 $log->info("Annotate $filename");
2001 # Prepare a file with the commits from the linearized
2002 # history that annotate should know about. This prevents
2003 # git-jsannotate telling us about commits we are hiding
2006 my $a_hints = "$work->{workDir}/.annotate_hints";
2007 if (!open(ANNOTATEHINTS
, '>', $a_hints)) {
2008 print "E failed to open '$a_hints' for writing: $!\n";
2011 for (my $i=0; $i < @
$revisions; $i++)
2013 print ANNOTATEHINTS
$revisions->[$i][2];
2014 if ($i+1 < @
$revisions) { # have we got a parent?
2015 print ANNOTATEHINTS
' ' . $revisions->[$i+1][2];
2017 print ANNOTATEHINTS
"\n";
2020 print ANNOTATEHINTS
"\n";
2022 or (print "E failed to write $a_hints: $!\n"), return;
2024 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2025 if (!open(ANNOTATE
, "-|", @cmd)) {
2026 print "E error invoking ". join(' ',@cmd) .": $!\n";
2030 print "E Annotations for $filename\n";
2031 print "E ***************\n";
2032 while ( <ANNOTATE
> )
2034 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2036 my $commithash = $1;
2038 unless ( defined ( $metadata->{$commithash} ) )
2040 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2041 $metadata->{$commithash}{author
} = cvs_author
($metadata->{$commithash}{author
});
2042 $metadata->{$commithash}{modified
} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2044 printf("M %-7s (%-8s %10s): %s\n",
2045 $metadata->{$commithash}{revision
},
2046 $metadata->{$commithash}{author
},
2047 $metadata->{$commithash}{modified
},
2051 $log->warn("Error in annotate output! LINE: $_");
2052 print "E Annotate error \n";
2059 # done; get out of the tempdir
2066 # This method takes the state->{arguments} array and produces two new arrays.
2067 # The first is $state->{args} which is everything before the '--' argument, and
2068 # the second is $state->{files} which is everything after it.
2071 $state->{args
} = [];
2072 $state->{files
} = [];
2075 return unless( defined($state->{arguments
}) and ref $state->{arguments
} eq "ARRAY" );
2079 if ( defined($type) )
2082 $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" );
2083 $opt = { v
=> 0, l
=> 0, R
=> 0 } if ( $type eq "status" );
2084 $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" );
2085 $opt = { l
=> 0, R
=> 0, k
=> 1, D
=> 1, D
=> 1, r
=> 2 } if ( $type eq "diff" );
2086 $opt = { c
=> 0, R
=> 0, l
=> 0, f
=> 0, F
=> 1, m
=> 1, r
=> 1 } if ( $type eq "ci" );
2087 $opt = { k
=> 1, m
=> 1 } if ( $type eq "add" );
2088 $opt = { f
=> 0, l
=> 0, R
=> 0 } if ( $type eq "remove" );
2089 $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" );
2092 while ( scalar ( @
{$state->{arguments
}} ) > 0 )
2094 my $arg = shift @
{$state->{arguments
}};
2096 next if ( $arg eq "--" );
2097 next unless ( $arg =~ /\S/ );
2099 # if the argument looks like a switch
2100 if ( $arg =~ /^-(\w)(.*)/ )
2102 # if it's a switch that takes an argument
2105 # If this switch has already been provided
2106 if ( $opt->{$1} > 1 and exists ( $state->{opt
}{$1} ) )
2108 $state->{opt
}{$1} = [ $state->{opt
}{$1} ];
2109 if ( length($2) > 0 )
2111 push @
{$state->{opt
}{$1}},$2;
2113 push @
{$state->{opt
}{$1}}, shift @
{$state->{arguments
}};
2116 # if there's extra data in the arg, use that as the argument for the switch
2117 if ( length($2) > 0 )
2119 $state->{opt
}{$1} = $2;
2121 $state->{opt
}{$1} = shift @
{$state->{arguments
}};
2125 $state->{opt
}{$1} = undef;
2130 push @
{$state->{args
}}, $arg;
2138 foreach my $value ( @
{$state->{arguments
}} )
2140 if ( $value eq "--" )
2145 push @
{$state->{args
}}, $value if ( $mode == 0 );
2146 push @
{$state->{files
}}, $value if ( $mode == 1 );
2151 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2154 my $updater = shift;
2156 $state->{args
} = [] if ( scalar(@
{$state->{args
}}) == 1 and $state->{args
}[0] eq "." );
2158 return if ( scalar ( @
{$state->{args
}} ) > 1 );
2160 my @gethead = @
{$updater->gethead};
2163 foreach my $file (keys %{$state->{entries
}}) {
2164 if ( exists $state->{entries
}{$file}{revision
} &&
2165 $state->{entries
}{$file}{revision
} eq '0' )
2167 push @gethead, { name
=> $file, filehash
=> 'added' };
2171 if ( scalar(@
{$state->{args
}}) == 1 )
2173 my $arg = $state->{args
}[0];
2174 $arg .= $state->{prependdir
} if ( defined ( $state->{prependdir
} ) );
2176 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2178 foreach my $file ( @gethead )
2180 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
2181 next unless ( $file->{name
} =~ /^$arg\// or $file->{name
} eq $arg );
2182 push @
{$state->{args
}}, $file->{name
};
2185 shift @
{$state->{args
}} if ( scalar(@
{$state->{args
}}) > 1 );
2187 $log->info("Only one arg specified, populating file list automatically");
2189 $state->{args
} = [];
2191 foreach my $file ( @gethead )
2193 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
2194 next unless ( $file->{name
} =~ s/^$state->{prependdir}// );
2195 push @
{$state->{args
}}, $file->{name
};
2200 # This method cleans up the $state variable after a command that uses arguments has run
2203 $state->{files
} = [];
2204 $state->{args
} = [];
2205 $state->{arguments
} = [];
2206 $state->{entries
} = {};
2209 # Return working directory CVS revision "1.X" out
2210 # of the the working directory "entries" state, for the given filename.
2211 # This is prefixed with a dash if the file is scheduled for removal
2212 # when it is committed.
2215 my $filename = shift;
2217 return $state->{entries
}{$filename}{revision
};
2220 # This method takes a file hash and does a CVS "file transfer". Its
2221 # exact behaviour depends on a second, optional hash table argument:
2222 # - If $options->{targetfile}, dump the contents to that file;
2223 # - If $options->{print}, use M/MT to transmit the contents one line
2225 # - Otherwise, transmit the size of the file, followed by the file
2229 my $filehash = shift;
2230 my $options = shift;
2232 if ( defined ( $filehash ) and $filehash eq "deleted" )
2234 $log->warn("filehash is 'deleted'");
2238 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2240 my $type = `git cat-file -t $filehash`;
2243 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2245 my $size = `git cat-file -s $filehash`;
2248 $log->debug("transmitfile($filehash) size=$size, type=$type");
2250 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2252 if ( defined ( $options->{targetfile
} ) )
2254 my $targetfile = $options->{targetfile
};
2255 open NEWFILE
, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2256 print NEWFILE
$_ while ( <$fh> );
2257 close NEWFILE
or die("Failed to write '$targetfile': $!");
2258 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2263 print 'MT text ', $_, "\n";
2268 print while ( <$fh> );
2270 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2272 die("Couldn't execute git-cat-file");
2276 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2277 # refers to the directory portion and the file portion of the filename
2281 my $filename = shift;
2282 my $fixforlocaldir = shift;
2284 my ( $filepart, $dirpart ) = ( $filename, "." );
2285 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2288 if ( $fixforlocaldir )
2290 $dirpart =~ s/^$state->{prependdir}//;
2293 return ( $filepart, $dirpart );
2298 my $filename = shift;
2300 return undef unless(defined($filename));
2301 if ( $filename =~ /^\// )
2303 print "E absolute filenames '$filename' not supported by server\n";
2307 $filename =~ s/^\.\///g
;
2308 $filename = $state->{prependdir
} . $filename;
2314 if( !defined($state->{CVSROOT
}) )
2316 print "error 1 CVSROOT not specified\n";
2320 if( $ENV{GIT_DIR
} ne ($state->{CVSROOT
} . '/') )
2322 print "error 1 Internally inconsistent CVSROOT\n";
2328 # Setup working directory in a work tree with the requested version
2329 # loaded in the index.
2336 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2337 defined($work->{tmpDir
}) )
2339 $log->warn("Bad work tree state management");
2340 print "error 1 Internal setup multiple work trees without cleanup\n";
2345 $work->{workDir
} = tempdir
( DIR
=> $TEMP_DIR );
2347 if( !defined($work->{index}) )
2349 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2352 chdir $work->{workDir
} or
2353 die "Unable to chdir to $work->{workDir}\n";
2355 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2357 $ENV{GIT_WORK_TREE
} = ".";
2358 $ENV{GIT_INDEX_FILE
} = $work->{index};
2363 system("git","read-tree",$ver);
2366 $log->warn("Error running git-read-tree");
2367 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2370 # else # req_annotate reads tree for each file
2373 # Ensure current directory is in some kind of working directory,
2374 # with a recent version loaded in the index.
2377 if( defined($work->{tmpDir
}) )
2379 $log->warn("Bad work tree state management [ensureWorkTree()]");
2380 print "error 1 Internal setup multiple dirs without cleanup\n";
2384 if( $work->{state} )
2391 if( !defined($work->{emptyDir
}) )
2393 $work->{emptyDir
} = tempdir
( DIR
=> $TEMP_DIR, OPEN
=> 0);
2395 chdir $work->{emptyDir
} or
2396 die "Unable to chdir to $work->{emptyDir}\n";
2398 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2400 if ($ver !~ /^[0-9a-f]{40}$/)
2402 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2403 print "error 1 cannot find the current HEAD of module";
2408 if( !defined($work->{index}) )
2410 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2413 $ENV{GIT_WORK_TREE
} = ".";
2414 $ENV{GIT_INDEX_FILE
} = $work->{index};
2417 system("git","read-tree",$ver);
2420 die "Error running git-read-tree $ver $!\n";
2424 # Cleanup working directory that is not needed any longer.
2427 if( ! $work->{state} )
2432 chdir "/" or die "Unable to chdir '/'\n";
2434 if( defined($work->{workDir
}) )
2436 rmtree
( $work->{workDir
} );
2437 undef $work->{workDir
};
2439 undef $work->{state};
2442 # Setup a temporary directory (not a working tree), typically for
2443 # merging dirty state as in req_update.
2446 $work->{tmpDir
} = tempdir
( DIR
=> $TEMP_DIR );
2447 chdir $work->{tmpDir
} or die "Unable to chdir $work->{tmpDir}\n";
2449 return $work->{tmpDir
};
2452 # Clean up a previously setupTmpDir. Restore previous work tree if
2456 if ( !defined($work->{tmpDir
}) )
2458 $log->warn("cleanup tmpdir that has not been setup");
2459 die "Cleanup tmpDir that has not been setup\n";
2461 if( defined($work->{state}) )
2463 if( $work->{state} == 1 )
2465 chdir $work->{emptyDir
} or
2466 die "Unable to chdir to $work->{emptyDir}\n";
2468 elsif( $work->{state} == 2 )
2470 chdir $work->{workDir
} or
2471 die "Unable to chdir to $work->{emptyDir}\n";
2475 $log->warn("Inconsistent work dir state");
2476 die "Inconsistent work dir state\n";
2481 chdir "/" or die "Unable to chdir '/'\n";
2485 # Given a path, this function returns a string containing the kopts
2486 # that should go into that path's Entries line. For example, a binary
2487 # file should get -kb.
2490 my ($path, $srcType, $name) = @_;
2492 if ( defined ( $cfg->{gitcvs
}{usecrlfattr
} ) and
2493 $cfg->{gitcvs
}{usecrlfattr
} =~ /\s*(1|true|yes)\s*$/i )
2495 my ($val) = check_attr
( "text", $path );
2496 if ( $val eq "unspecified" )
2498 $val = check_attr
( "crlf", $path );
2500 if ( $val eq "unset" )
2504 elsif ( check_attr
( "eol", $path ) ne "unspecified" ||
2505 $val eq "set" || $val eq "input" )
2511 $log->info("Unrecognized check_attr crlf $path : $val");
2515 if ( defined ( $cfg->{gitcvs
}{allbinary
} ) )
2517 if( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*(1|true|yes)\s*$/i) )
2521 elsif( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*guess\s*$/i) )
2523 if( is_binary
($srcType,$name) )
2525 $log->debug("... as binary");
2530 $log->debug("... as text");
2534 # Return "" to give no special treatment to any path
2540 my ($attr,$path) = @_;
2542 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2546 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2555 # This should have the same heuristics as convert.c:is_binary() and related.
2556 # Note that the bare CR test is done by callers in convert.c.
2559 my ($srcType,$name) = @_;
2560 $log->debug("is_binary($srcType,$name)");
2562 # Minimize amount of interpreted code run in the inner per-character
2563 # loop for large files, by totalling each character value and
2564 # then analyzing the totals.
2567 for($i=0;$i<256;$i++)
2572 my $fh = open_blob_or_die
($srcType,$name);
2574 while( defined($line=<$fh>) )
2576 # Any '\0' and bare CR are considered binary.
2577 if( $line =~ /\0|(\r[^\n])/ )
2583 # Count up each character in the line:
2584 my $len=length($line);
2585 for($i=0;$i<$len;$i++)
2587 $counts[ord(substr($line,$i,1))]++;
2592 # Don't count CR and LF as either printable/nonprintable
2593 $counts[ord("\n")]=0;
2594 $counts[ord("\r")]=0;
2596 # Categorize individual character count into printable and nonprintable:
2599 for($i=0;$i<256;$i++)
2607 $nonprintable+=$counts[$i];
2609 elsif( $i==127 ) # DEL
2611 $nonprintable+=$counts[$i];
2615 $printable+=$counts[$i];
2619 return ($printable >> 7) < $nonprintable;
2622 # Returns open file handle. Possible invocations:
2623 # - open_blob_or_die("file",$filename);
2624 # - open_blob_or_die("sha1",$filehash);
2625 sub open_blob_or_die
2627 my ($srcType,$name) = @_;
2629 if( $srcType eq "file" )
2631 if( !open $fh,"<",$name )
2633 $log->warn("Unable to open file $name: $!");
2634 die "Unable to open file $name: $!\n";
2637 elsif( $srcType eq "sha1" )
2639 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2641 $log->warn("Need filehash");
2642 die "Need filehash\n";
2645 my $type = `git cat-file -t $name`;
2648 unless ( defined ( $type ) and $type eq "blob" )
2650 $log->warn("Invalid type '$type' for '$name'");
2651 die ( "Invalid type '$type' (expected 'blob')" )
2654 my $size = `git cat-file -s $name`;
2657 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2659 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2661 $log->warn("Unable to open sha1 $name");
2662 die "Unable to open sha1 $name\n";
2667 $log->warn("Unknown type of blob source: $srcType");
2668 die "Unknown type of blob source: $srcType\n";
2673 # Generate a CVS author name from Git author information, by taking the local
2674 # part of the email address and replacing characters not in the Portable
2675 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2676 # Login names are Unix login names, which should be restricted to this
2680 my $author_line = shift;
2681 (my $author) = $author_line =~ /<([^@>]*)/;
2683 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2692 # This table is from src/scramble.c in the CVS source
2694 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2695 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2696 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2697 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2698 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2699 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2700 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2701 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2702 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2703 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2704 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2705 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2706 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2707 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2708 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2709 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2713 # This should never happen, the same password format (A) has been
2714 # used by CVS since the beginning of time
2716 my $fmt = substr($str, 0, 1);
2717 die "invalid password format `$fmt'" unless $fmt eq 'A';
2720 my @str = unpack "C*", substr($str, 1);
2721 my $ret = join '', map { chr $SHIFTS[$_] } @str;
2726 package GITCVS
::log;
2729 #### Copyright The Open University UK - 2006.
2731 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2732 #### Martin Langhoff <martin@laptop.org>
2745 This module provides very crude logging with a similar interface to
2754 Creates a new log object, optionally you can specify a filename here to
2755 indicate the file to log to. If no log file is specified, you can specify one
2756 later with method setfile, or indicate you no longer want logging with method
2759 Until one of these methods is called, all log calls will buffer messages ready
2766 my $filename = shift;
2770 bless $self, $class;
2772 if ( defined ( $filename ) )
2774 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2782 This methods takes a filename, and attempts to open that file as the log file.
2783 If successful, all buffered data is written out to the file, and any further
2784 logging is written directly to the file.
2790 my $filename = shift;
2792 if ( defined ( $filename ) )
2794 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2797 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2799 while ( my $line = shift @
{$self->{buffer
}} )
2801 print {$self->{fh
}} $line;
2807 This method indicates no logging is going to be used. It flushes any entries in
2808 the internal buffer, and sets a flag to ensure no further data is put there.
2817 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2819 $self->{buffer
} = [];
2824 Internal method. Returns true if the log file is open, false otherwise.
2831 return 1 if ( defined ( $self->{fh
} ) and ref $self->{fh
} eq "GLOB" );
2835 =head2 debug info warn fatal
2837 These four methods are wrappers to _log. They provide the actual interface for
2841 sub debug
{ my $self = shift; $self->_log("debug", @_); }
2842 sub info
{ my $self = shift; $self->_log("info" , @_); }
2843 sub warn { my $self = shift; $self->_log("warn" , @_); }
2844 sub fatal
{ my $self = shift; $self->_log("fatal", @_); }
2848 This is an internal method called by the logging functions. It generates a
2849 timestamp and pushes the logged line either to file, or internal buffer.
2857 return if ( $self->{nolog
} );
2859 my @time = localtime;
2860 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2870 if ( $self->_logopen )
2872 print {$self->{fh
}} $timestring . " - " . join(" ",@_) . "\n";
2874 push @
{$self->{buffer
}}, $timestring . " - " . join(" ",@_) . "\n";
2880 This method simply closes the file handle if one is open
2887 if ( $self->_logopen )
2893 package GITCVS
::updater
;
2896 #### Copyright The Open University UK - 2006.
2898 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2899 #### Martin Langhoff <martin@laptop.org>
2921 die "Need to specify a git repository" unless ( defined($config) and -d
$config );
2922 die "Need to specify a module" unless ( defined($module) );
2924 $class = ref($class) || $class;
2928 bless $self, $class;
2930 $self->{valid_tables
} = {'revision' => 1,
2931 'revision_ix1' => 1,
2932 'revision_ix2' => 1,
2938 $self->{module
} = $module;
2939 $self->{git_path
} = $config . "/";
2941 $self->{log} = $log;
2943 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d
$self->{git_path
} );
2945 $self->{dbdriver
} = $cfg->{gitcvs
}{$state->{method
}}{dbdriver
} ||
2946 $cfg->{gitcvs
}{dbdriver
} || "SQLite";
2947 $self->{dbname
} = $cfg->{gitcvs
}{$state->{method
}}{dbname
} ||
2948 $cfg->{gitcvs
}{dbname
} || "%Ggitcvs.%m.sqlite";
2949 $self->{dbuser
} = $cfg->{gitcvs
}{$state->{method
}}{dbuser
} ||
2950 $cfg->{gitcvs
}{dbuser
} || "";
2951 $self->{dbpass
} = $cfg->{gitcvs
}{$state->{method
}}{dbpass
} ||
2952 $cfg->{gitcvs
}{dbpass
} || "";
2953 $self->{dbtablenameprefix
} = $cfg->{gitcvs
}{$state->{method
}}{dbtablenameprefix
} ||
2954 $cfg->{gitcvs
}{dbtablenameprefix
} || "";
2955 my %mapping = ( m
=> $module,
2956 a
=> $state->{method
},
2957 u
=> getlogin || getpwuid($<) || $<,
2958 G
=> $self->{git_path
},
2959 g
=> mangle_dirname
($self->{git_path
}),
2961 $self->{dbname
} =~ s/%([mauGg])/$mapping{$1}/eg;
2962 $self->{dbuser
} =~ s/%([mauGg])/$mapping{$1}/eg;
2963 $self->{dbtablenameprefix
} =~ s/%([mauGg])/$mapping{$1}/eg;
2964 $self->{dbtablenameprefix
} = mangle_tablename
($self->{dbtablenameprefix
});
2966 die "Invalid char ':' in dbdriver" if $self->{dbdriver
} =~ /:/;
2967 die "Invalid char ';' in dbname" if $self->{dbname
} =~ /;/;
2968 $self->{dbh
} = DBI
->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2971 die "Error connecting to database\n" unless defined $self->{dbh
};
2973 $self->{tables
} = {};
2974 foreach my $table ( keys %{$self->{dbh
}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2976 $self->{tables
}{$table} = 1;
2979 # Construct the revision table if required
2980 # The revision table stores an entry for each file, each time that file
2982 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
2983 # This is not sufficient to support "-r {commithash}" for any
2984 # files except files that were modified by that commit (also,
2985 # some places in the code ignore/effectively strip out -r in
2986 # some cases, before it gets passed to getmeta()).
2987 # The "filehash" field typically has a git blob hash, but can also
2988 # be set to "dead" to indicate that the given version of the file
2989 # should not exist in the sandbox.
2990 unless ( $self->{tables
}{$self->tablename("revision")} )
2992 my $tablename = $self->tablename("revision");
2993 my $ix1name = $self->tablename("revision_ix1");
2994 my $ix2name = $self->tablename("revision_ix2");
2996 CREATE TABLE $tablename (
2998 revision INTEGER NOT NULL,
2999 filehash TEXT NOT NULL,
3000 commithash TEXT NOT NULL,
3001 author TEXT NOT NULL,
3002 modified TEXT NOT NULL,
3007 CREATE INDEX $ix1name
3008 ON $tablename (name,revision)
3011 CREATE INDEX $ix2name
3012 ON $tablename (name,commithash)
3016 # Construct the head table if required
3017 # The head table (along with the "last_commit" entry in the property
3018 # table) is the persisted working state of the "sub update" subroutine.
3019 # All of it's data is read entirely first, and completely recreated
3020 # last, every time "sub update" runs.
3021 # This is also used by "sub getmeta" when it is asked for the latest
3022 # version of a file (as opposed to some specific version).
3023 # Another way of thinking about it is as a single slice out of
3024 # "revisions", giving just the most recent revision information for
3026 unless ( $self->{tables
}{$self->tablename("head")} )
3028 my $tablename = $self->tablename("head");
3029 my $ix1name = $self->tablename("head_ix1");
3031 CREATE TABLE $tablename (
3033 revision INTEGER NOT NULL,
3034 filehash TEXT NOT NULL,
3035 commithash TEXT NOT NULL,
3036 author TEXT NOT NULL,
3037 modified TEXT NOT NULL,
3042 CREATE INDEX $ix1name
3043 ON $tablename (name)
3047 # Construct the properties table if required
3048 # - "last_commit" - Used by "sub update".
3049 unless ( $self->{tables
}{$self->tablename("properties")} )
3051 my $tablename = $self->tablename("properties");
3053 CREATE TABLE $tablename (
3054 key TEXT NOT NULL PRIMARY KEY,
3060 # Construct the commitmsgs table if required
3061 # The commitmsgs table is only used for merge commits, since
3062 # "sub update" will only keep one branch of parents. Shortlogs
3063 # for ignored commits (i.e. not on the chosen branch) will be used
3064 # to construct a replacement "collapsed" merge commit message,
3065 # which will be stored in this table. See also "sub commitmessage".
3066 unless ( $self->{tables
}{$self->tablename("commitmsgs")} )
3068 my $tablename = $self->tablename("commitmsgs");
3070 CREATE TABLE $tablename (
3071 key TEXT NOT NULL PRIMARY KEY,
3088 if (exists $self->{valid_tables
}{$name}) {
3089 return $self->{dbtablenameprefix
} . $name;
3097 Bring the database up to date with the latest changes from
3100 Internal working state is read out of the "head" table and the
3101 "last_commit" property, then it updates "revisions" based on that, and
3102 finally it writes the new internal state back to the "head" table
3103 so it can be used as a starting point the next time update is called.
3110 # first lets get the commit list
3111 $ENV{GIT_DIR
} = $self->{git_path
};
3113 my $commitsha1 = `git rev-parse $self->{module}`;
3116 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3117 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3119 die("Invalid module '$self->{module}'");
3124 my $lastcommit = $self->_get_prop("last_commit");
3126 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3130 # Start exclusive lock here...
3131 $self->{dbh
}->begin_work() or die "Cannot lock database for BEGIN";
3133 # TODO: log processing is memory bound
3134 # if we can parse into a 2nd file that is in reverse order
3135 # we can probably do something really efficient
3136 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3138 if (defined $lastcommit) {
3139 push @git_log_params, "$lastcommit..$self->{module}";
3141 push @git_log_params, $self->{module
};
3143 # git-rev-list is the backend / plumbing version of git-log
3144 open(GITLOG
, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3153 if (m/^commit\s+(.*)$/) {
3154 # on ^commit lines put the just seen commit in the stack
3155 # and prime things for the next one
3158 unshift @commits, \
%copy;
3161 my @parents = split(m/\s+/, $1);
3162 $commit{hash
} = shift @parents;
3163 $commit{parents
} = \
@parents;
3164 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message
})) {
3165 # on rfc822-like lines seen before we see any message,
3166 # lowercase the entry and put it in the hash as key-value
3167 $commit{lc($1)} = $2;
3169 # message lines - skip initial empty line
3170 # and trim whitespace
3171 if (!exists($commit{message
}) && m/^\s*$/) {
3172 # define it to mark the end of headers
3173 $commit{message
} = '';
3176 s/^\s+//; s/\s+$//; # trim ws
3177 $commit{message
} .= $_ . "\n";
3182 unshift @commits, \
%commit if ( keys %commit );
3184 # Now all the commits are in the @commits bucket
3185 # ordered by time DESC. for each commit that needs processing,
3186 # determine whether it's following the last head we've seen or if
3187 # it's on its own branch, grab a file list, and add whatever's changed
3188 # NOTE: $lastcommit refers to the last commit from previous run
3189 # $lastpicked is the last commit we picked in this run
3192 if (defined $lastcommit) {
3193 $lastpicked = $lastcommit;
3196 my $committotal = scalar(@commits);
3197 my $commitcount = 0;
3199 # Load the head table into $head (for cached lookups during the update process)
3200 foreach my $file ( @
{$self->gethead(1)} )
3202 $head->{$file->{name
}} = $file;
3205 foreach my $commit ( @commits )
3207 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3208 if (defined $lastpicked)
3210 if (!in_array
($lastpicked, @
{$commit->{parents
}}))
3212 # skip, we'll see this delta
3213 # as part of a merge later
3214 # warn "skipping off-track $commit->{hash}\n";
3216 } elsif (@
{$commit->{parents
}} > 1) {
3217 # it is a merge commit, for each parent that is
3218 # not $lastpicked (not given a CVS revision number),
3219 # see if we can get a log
3220 # from the merge-base to that parent to put it
3221 # in the message as a merge summary.
3222 my @parents = @
{$commit->{parents
}};
3223 foreach my $parent (@parents) {
3224 if ($parent eq $lastpicked) {
3227 # git-merge-base can potentially (but rarely) throw
3228 # several candidate merge bases. let's assume
3229 # that the first one is the best one.
3231 safe_pipe_capture
('git', 'merge-base',
3232 $lastpicked, $parent);
3234 # The two branches may not be related at all,
3235 # in which case merge base simply fails to find
3236 # any, but that's Ok.
3242 # print "want to log between $base $parent \n";
3243 open(GITLOG
, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3244 or die "Cannot call git-log: $!";
3248 if (!defined $mergedhash) {
3249 if (m/^commit\s+(.+)$/) {
3255 # grab the first line that looks non-rfc822
3256 # aka has content after leading space
3257 if (m/^\s+(\S.*)$/) {
3259 $title = substr($title,0,100); # truncate
3260 unshift @merged, "$mergedhash $title";
3267 $commit->{mergemsg
} = $commit->{message
};
3268 $commit->{mergemsg
} .= "\nSummary of merged commits:\n\n";
3269 foreach my $summary (@merged) {
3270 $commit->{mergemsg
} .= "\t$summary\n";
3272 $commit->{mergemsg
} .= "\n\n";
3273 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3280 # convert the date to CVS-happy format
3281 $commit->{date
} = "$2 $1 $4 $3 $5" if ( $commit->{date
} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3283 if ( defined ( $lastpicked ) )
3285 my $filepipe = open(FILELIST
, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash
}) or die("Cannot call git-diff-tree : $!");
3287 while ( <FILELIST
> )
3290 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3292 die("Couldn't process git-diff-tree line : $_");
3294 my ($mode, $hash, $change) = ($1, $2, $3);
3295 my $name = <FILELIST
>;
3298 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3301 $git_perms .= "r" if ( $mode & 4 );
3302 $git_perms .= "w" if ( $mode & 2 );
3303 $git_perms .= "x" if ( $mode & 1 );
3304 $git_perms = "rw" if ( $git_perms eq "" );
3306 if ( $change eq "D" )
3308 #$log->debug("DELETE $name");
3311 revision
=> $head->{$name}{revision
} + 1,
3312 filehash
=> "deleted",
3313 commithash
=> $commit->{hash
},
3314 modified
=> $commit->{date
},
3315 author
=> $commit->{author
},
3318 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3320 elsif ( $change eq "M" || $change eq "T" )
3322 #$log->debug("MODIFIED $name");
3325 revision
=> $head->{$name}{revision
} + 1,
3327 commithash
=> $commit->{hash
},
3328 modified
=> $commit->{date
},
3329 author
=> $commit->{author
},
3332 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3334 elsif ( $change eq "A" )
3336 #$log->debug("ADDED $name");
3339 revision
=> $head->{$name}{revision
} ?
$head->{$name}{revision
}+1 : 1,
3341 commithash
=> $commit->{hash
},
3342 modified
=> $commit->{date
},
3343 author
=> $commit->{author
},
3346 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3350 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3356 # this is used to detect files removed from the repo
3357 my $seen_files = {};
3359 my $filepipe = open(FILELIST
, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash
}) or die("Cannot call git-ls-tree : $!");
3361 while ( <FILELIST
> )
3364 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3366 die("Couldn't process git-ls-tree line : $_");
3369 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3371 $seen_files->{$git_filename} = 1;
3373 my ( $oldhash, $oldrevision, $oldmode ) = (
3374 $head->{$git_filename}{filehash
},
3375 $head->{$git_filename}{revision
},
3376 $head->{$git_filename}{mode
}
3379 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3382 $git_perms .= "r" if ( $1 & 4 );
3383 $git_perms .= "w" if ( $1 & 2 );
3384 $git_perms .= "x" if ( $1 & 1 );
3389 # unless the file exists with the same hash, we need to update it ...
3390 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3392 my $newrevision = ( $oldrevision or 0 ) + 1;
3394 $head->{$git_filename} = {
3395 name
=> $git_filename,
3396 revision
=> $newrevision,
3397 filehash
=> $git_hash,
3398 commithash
=> $commit->{hash
},
3399 modified
=> $commit->{date
},
3400 author
=> $commit->{author
},
3405 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3410 # Detect deleted files
3411 foreach my $file ( keys %$head )
3413 unless ( exists $seen_files->{$file} or $head->{$file}{filehash
} eq "deleted" )
3415 $head->{$file}{revision
}++;
3416 $head->{$file}{filehash
} = "deleted";
3417 $head->{$file}{commithash
} = $commit->{hash
};
3418 $head->{$file}{modified
} = $commit->{date
};
3419 $head->{$file}{author
} = $commit->{author
};
3421 $self->insert_rev($file, $head->{$file}{revision
}, $head->{$file}{filehash
}, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $head->{$file}{mode
});
3424 # END : "Detect deleted files"
3428 if (exists $commit->{mergemsg
})
3430 $self->insert_mergelog($commit->{hash
}, $commit->{mergemsg
});
3433 $lastpicked = $commit->{hash
};
3435 $self->_set_prop("last_commit", $commit->{hash
});
3438 $self->delete_head();
3439 foreach my $file ( keys %$head )
3443 $head->{$file}{revision
},
3444 $head->{$file}{filehash
},
3445 $head->{$file}{commithash
},
3446 $head->{$file}{modified
},
3447 $head->{$file}{author
},
3448 $head->{$file}{mode
},
3451 # invalidate the gethead cache
3452 $self->{gethead_cache
} = undef;
3455 # Ending exclusive lock here
3456 $self->{dbh
}->commit() or die "Failed to commit changes to SQLite";
3463 my $revision = shift;
3464 my $filehash = shift;
3465 my $commithash = shift;
3466 my $modified = shift;
3469 my $tablename = $self->tablename("revision");
3471 my $insert_rev = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3472 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3480 my $tablename = $self->tablename("commitmsgs");
3482 my $insert_mergelog = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3483 $insert_mergelog->execute($key, $value);
3489 my $tablename = $self->tablename("head");
3491 my $delete_head = $self->{dbh
}->prepare_cached("DELETE FROM $tablename",{},1);
3492 $delete_head->execute();
3499 my $revision = shift;
3500 my $filehash = shift;
3501 my $commithash = shift;
3502 my $modified = shift;
3505 my $tablename = $self->tablename("head");
3507 my $insert_head = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3508 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3515 my $tablename = $self->tablename("properties");
3517 my $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3518 $db_query->execute($key);
3519 my ( $value ) = $db_query->fetchrow_array;
3529 my $tablename = $self->tablename("properties");
3531 my $db_query = $self->{dbh
}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3532 $db_query->execute($value, $key);
3534 unless ( $db_query->rows )
3536 $db_query = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3537 $db_query->execute($key, $value);
3551 my $tablename = $self->tablename("head");
3553 return $self->{gethead_cache
} if ( defined ( $self->{gethead_cache
} ) );
3555 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3556 $db_query->execute();
3559 while ( my $file = $db_query->fetchrow_hashref )
3563 $file->{revision
} = "1.$file->{revision}"
3568 $self->{gethead_cache
} = $tree;
3575 See also gethistorydense().
3582 my $filename = shift;
3583 my $revFilter = shift;
3585 my $tablename = $self->tablename("revision");
3588 # TODO: date, state, or by specific logins filters?
3589 # TODO: Handle comma-separated list of revFilter items, each item
3590 # can be a range [only case currently handled] or individual
3591 # rev or branch or "branch.".
3592 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
3593 # manually filtering the results of the query?
3594 my ( $minrev, $maxrev );
3595 if( defined($revFilter) and
3596 $state->{opt
}{r
} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
3601 $minrev++ if ( defined($minrev) and $control eq "::" );
3604 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3605 $db_query->execute($filename);
3609 while ( my $file = $db_query->fetchrow_hashref )
3612 if( defined($minrev) and $file->{revision
} < $minrev )
3616 if( defined($maxrev) and $file->{revision
} > $maxrev )
3621 $file->{revision
} = "1." . $file->{revision
};
3625 return ($tree,$totalRevs);
3630 This function takes a filename (with path) argument and returns a hashref of
3631 metadata for that file.
3638 my $filename = shift;
3639 my $revision = shift;
3640 my $tablename_rev = $self->tablename("revision");
3641 my $tablename_head = $self->tablename("head");
3644 if ( defined($revision) and $revision =~ /^1\.(\d+)$/ )
3647 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3648 $db_query->execute($filename, $intRev);
3650 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3652 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3653 $db_query->execute($filename, $revision);
3655 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3656 $db_query->execute($filename);
3659 my $meta = $db_query->fetchrow_hashref;
3662 $meta->{revision
} = "1.$meta->{revision}";
3667 =head2 commitmessage
3669 this function takes a commithash and returns the commit message for that commit
3675 my $commithash = shift;
3676 my $tablename = $self->tablename("commitmsgs");
3678 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3681 $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3682 $db_query->execute($commithash);
3684 my ( $message ) = $db_query->fetchrow_array;
3686 if ( defined ( $message ) )
3688 $message .= " " if ( $message =~ /\n$/ );
3692 my @lines = safe_pipe_capture
("git", "cat-file", "commit", $commithash);
3693 shift @lines while ( $lines[0] =~ /\S/ );
3694 $message = join("",@lines);
3695 $message .= " " if ( $message =~ /\n$/ );
3699 =head2 gethistorydense
3701 This function takes a filename (with path) argument and returns an arrayofarrays
3702 containing revision,filehash,commithash ordered by revision descending.
3704 This version of gethistory skips deleted entries -- so it is useful for annotate.
3705 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3706 and other git tools that depend on it.
3714 my $filename = shift;
3715 my $tablename = $self->tablename("revision");
3718 $db_query = $self->{dbh
}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3719 $db_query->execute($filename);
3721 my $result = $db_query->fetchall_arrayref;
3724 for($i=0 ; $i<scalar(@
$result) ; $i++)
3726 $result->[$i][0]="1." . $result->[$i][0];
3734 from Array::PAT - mimics the in_array() function
3735 found in PHP. Yuck but works for small arrays.
3740 my ($check, @array) = @_;
3742 foreach my $test (@array){
3743 if($check eq $test){
3750 =head2 safe_pipe_capture
3752 an alternative to `command` that allows input to be passed as an array
3753 to work around shell problems with weird characters in arguments
3756 sub safe_pipe_capture
{
3760 if (my $pid = open my $child, '-|') {
3761 @output = (<$child>);
3762 close $child or die join(' ',@_).": $! $?";
3764 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3766 return wantarray ?
@output : join('',@output);
3769 =head2 mangle_dirname
3771 create a string from a directory name that is suitable to use as
3772 part of a filename, mainly by converting all chars except \w.- to _
3775 sub mangle_dirname
{
3776 my $dirname = shift;
3777 return unless defined $dirname;
3779 $dirname =~ s/[^\w.-]/_/g;
3784 =head2 mangle_tablename
3786 create a string from a that is suitable to use as part of an SQL table
3787 name, mainly by converting all chars except \w to _
3790 sub mangle_tablename
{
3791 my $tablename = shift;
3792 return unless defined $tablename;
3794 $tablename =~ s/[^\w_]/_/g;