Make "index_name_exists()" return the cache_entry it found
[git/dscho.git] / git-cvsserver.perl
blob29dbfc940b6c8ec10c9e0eb12d08a70581fe870c
1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
20 use bytes;
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Basename;
25 use Getopt::Long qw(:config require_order no_ignore_case);
27 my $VERSION = '@@GIT_VERSION@@';
29 my $log = GITCVS::log->new();
30 my $cfg;
32 my $DATE_LIST = {
33 Jan => "01",
34 Feb => "02",
35 Mar => "03",
36 Apr => "04",
37 May => "05",
38 Jun => "06",
39 Jul => "07",
40 Aug => "08",
41 Sep => "09",
42 Oct => "10",
43 Nov => "11",
44 Dec => "12",
47 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
48 $| = 1;
50 #### Definition and mappings of functions ####
52 my $methods = {
53 'Root' => \&req_Root,
54 'Valid-responses' => \&req_Validresponses,
55 'valid-requests' => \&req_validrequests,
56 'Directory' => \&req_Directory,
57 'Entry' => \&req_Entry,
58 'Modified' => \&req_Modified,
59 'Unchanged' => \&req_Unchanged,
60 'Questionable' => \&req_Questionable,
61 'Argument' => \&req_Argument,
62 'Argumentx' => \&req_Argument,
63 'expand-modules' => \&req_expandmodules,
64 'add' => \&req_add,
65 'remove' => \&req_remove,
66 'co' => \&req_co,
67 'update' => \&req_update,
68 'ci' => \&req_ci,
69 'diff' => \&req_diff,
70 'log' => \&req_log,
71 'rlog' => \&req_log,
72 'tag' => \&req_CATCHALL,
73 'status' => \&req_status,
74 'admin' => \&req_CATCHALL,
75 'history' => \&req_CATCHALL,
76 'watchers' => \&req_EMPTY,
77 'editors' => \&req_EMPTY,
78 'annotate' => \&req_annotate,
79 'Global_option' => \&req_Globaloption,
80 #'annotate' => \&req_CATCHALL,
83 ##############################################
86 # $state holds all the bits of information the clients sends us that could
87 # potentially be useful when it comes to actually _doing_ something.
88 my $state = { prependdir => '' };
89 $log->info("--------------- STARTING -----------------");
91 my $usage =
92 "Usage: git-cvsserver [options] [pserver|server] [<directory> ...]\n".
93 " --base-path <path> : Prepend to requested CVSROOT\n".
94 " --strict-paths : Don't allow recursing into subdirectories\n".
95 " --export-all : Don't check for gitcvs.enabled in config\n".
96 " --version, -V : Print version information and exit\n".
97 " --help, -h, -H : Print usage information and exit\n".
98 "\n".
99 "<directory> ... is a list of allowed directories. If no directories\n".
100 "are given, all are allowed. This is an additional restriction, gitcvs\n".
101 "access still needs to be enabled by the gitcvs.enabled config option.\n";
103 my @opts = ( 'help|h|H', 'version|V',
104 'base-path=s', 'strict-paths', 'export-all' );
105 GetOptions( $state, @opts )
106 or die $usage;
108 if ($state->{version}) {
109 print "git-cvsserver version $VERSION\n";
110 exit;
112 if ($state->{help}) {
113 print $usage;
114 exit;
117 my $TEMP_DIR = tempdir( CLEANUP => 1 );
118 $log->debug("Temporary directory is '$TEMP_DIR'");
120 $state->{method} = 'ext';
121 if (@ARGV) {
122 if ($ARGV[0] eq 'pserver') {
123 $state->{method} = 'pserver';
124 shift @ARGV;
125 } elsif ($ARGV[0] eq 'server') {
126 shift @ARGV;
130 # everything else is a directory
131 $state->{allowed_roots} = [ @ARGV ];
133 # don't export the whole system unless the users requests it
134 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
135 die "--export-all can only be used together with an explicit whitelist\n";
138 # if we are called with a pserver argument,
139 # deal with the authentication cat before entering the
140 # main loop
141 if ($state->{method} eq 'pserver') {
142 my $line = <STDIN>; chomp $line;
143 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
144 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
146 my $request = $1;
147 $line = <STDIN>; chomp $line;
148 unless (req_Root('root', $line)) { # reuse Root
149 print "E Invalid root $line \n";
150 exit 1;
152 $line = <STDIN>; chomp $line;
153 unless ($line eq 'anonymous') {
154 print "E Only anonymous user allowed via pserver\n";
155 print "I HATE YOU\n";
156 exit 1;
158 $line = <STDIN>; chomp $line; # validate the password?
159 $line = <STDIN>; chomp $line;
160 unless ($line eq "END $request REQUEST") {
161 die "E Do not understand $line -- expecting END $request REQUEST\n";
163 print "I LOVE YOU\n";
164 exit if $request eq 'VERIFICATION'; # cvs login
165 # and now back to our regular programme...
168 # Keep going until the client closes the connection
169 while (<STDIN>)
171 chomp;
173 # Check to see if we've seen this method, and call appropriate function.
174 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
176 # use the $methods hash to call the appropriate sub for this command
177 #$log->info("Method : $1");
178 &{$methods->{$1}}($1,$2);
179 } else {
180 # log fatal because we don't understand this function. If this happens
181 # we're fairly screwed because we don't know if the client is expecting
182 # a response. If it is, the client will hang, we'll hang, and the whole
183 # thing will be custard.
184 $log->fatal("Don't understand command $_\n");
185 die("Unknown command $_");
189 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
190 $log->info("--------------- FINISH -----------------");
192 # Magic catchall method.
193 # This is the method that will handle all commands we haven't yet
194 # implemented. It simply sends a warning to the log file indicating a
195 # command that hasn't been implemented has been invoked.
196 sub req_CATCHALL
198 my ( $cmd, $data ) = @_;
199 $log->warn("Unhandled command : req_$cmd : $data");
202 # This method invariably succeeds with an empty response.
203 sub req_EMPTY
205 print "ok\n";
208 # Root pathname \n
209 # Response expected: no. Tell the server which CVSROOT to use. Note that
210 # pathname is a local directory and not a fully qualified CVSROOT variable.
211 # pathname must already exist; if creating a new root, use the init
212 # request, not Root. pathname does not include the hostname of the server,
213 # how to access the server, etc.; by the time the CVS protocol is in use,
214 # connection, authentication, etc., are already taken care of. The Root
215 # request must be sent only once, and it must be sent before any requests
216 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
217 sub req_Root
219 my ( $cmd, $data ) = @_;
220 $log->debug("req_Root : $data");
222 unless ($data =~ m#^/#) {
223 print "error 1 Root must be an absolute pathname\n";
224 return 0;
227 my $cvsroot = $state->{'base-path'} || '';
228 $cvsroot =~ s#/+$##;
229 $cvsroot .= $data;
231 if ($state->{CVSROOT}
232 && ($state->{CVSROOT} ne $cvsroot)) {
233 print "error 1 Conflicting roots specified\n";
234 return 0;
237 $state->{CVSROOT} = $cvsroot;
239 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
241 if (@{$state->{allowed_roots}}) {
242 my $allowed = 0;
243 foreach my $dir (@{$state->{allowed_roots}}) {
244 next unless $dir =~ m#^/#;
245 $dir =~ s#/+$##;
246 if ($state->{'strict-paths'}) {
247 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
248 $allowed = 1;
249 last;
251 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
252 $allowed = 1;
253 last;
257 unless ($allowed) {
258 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
259 print "E \n";
260 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
261 return 0;
265 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
266 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
267 print "E \n";
268 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
269 return 0;
272 my @gitvars = `git-config -l`;
273 if ($?) {
274 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
275 print "E \n";
276 print "error 1 - problem executing git-config\n";
277 return 0;
279 foreach my $line ( @gitvars )
281 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
282 unless ($2) {
283 $cfg->{$1}{$3} = $4;
284 } else {
285 $cfg->{$1}{$2}{$3} = $4;
289 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
290 || $cfg->{gitcvs}{enabled});
291 unless ($state->{'export-all'} ||
292 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
293 print "E GITCVS emulation needs to be enabled on this repo\n";
294 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
295 print "E \n";
296 print "error 1 GITCVS emulation disabled\n";
297 return 0;
300 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
301 if ( $logfile )
303 $log->setfile($logfile);
304 } else {
305 $log->nofile();
308 return 1;
311 # Global_option option \n
312 # Response expected: no. Transmit one of the global options `-q', `-Q',
313 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
314 # variations (such as combining of options) are allowed. For graceful
315 # handling of valid-requests, it is probably better to make new global
316 # options separate requests, rather than trying to add them to this
317 # request.
318 sub req_Globaloption
320 my ( $cmd, $data ) = @_;
321 $log->debug("req_Globaloption : $data");
322 $state->{globaloptions}{$data} = 1;
325 # Valid-responses request-list \n
326 # Response expected: no. Tell the server what responses the client will
327 # accept. request-list is a space separated list of tokens.
328 sub req_Validresponses
330 my ( $cmd, $data ) = @_;
331 $log->debug("req_Validresponses : $data");
333 # TODO : re-enable this, currently it's not particularly useful
334 #$state->{validresponses} = [ split /\s+/, $data ];
337 # valid-requests \n
338 # Response expected: yes. Ask the server to send back a Valid-requests
339 # response.
340 sub req_validrequests
342 my ( $cmd, $data ) = @_;
344 $log->debug("req_validrequests");
346 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
347 $log->debug("SEND : ok");
349 print "Valid-requests " . join(" ",keys %$methods) . "\n";
350 print "ok\n";
353 # Directory local-directory \n
354 # Additional data: repository \n. Response expected: no. Tell the server
355 # what directory to use. The repository should be a directory name from a
356 # previous server response. Note that this both gives a default for Entry
357 # and Modified and also for ci and the other commands; normal usage is to
358 # send Directory for each directory in which there will be an Entry or
359 # Modified, and then a final Directory for the original directory, then the
360 # command. The local-directory is relative to the top level at which the
361 # command is occurring (i.e. the last Directory which is sent before the
362 # command); to indicate that top level, `.' should be sent for
363 # local-directory.
364 sub req_Directory
366 my ( $cmd, $data ) = @_;
368 my $repository = <STDIN>;
369 chomp $repository;
372 $state->{localdir} = $data;
373 $state->{repository} = $repository;
374 $state->{path} = $repository;
375 $state->{path} =~ s/^$state->{CVSROOT}\///;
376 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
377 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
379 $state->{directory} = $state->{localdir};
380 $state->{directory} = "" if ( $state->{directory} eq "." );
381 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
383 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
385 $log->info("Setting prepend to '$state->{path}'");
386 $state->{prependdir} = $state->{path};
387 foreach my $entry ( keys %{$state->{entries}} )
389 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
390 delete $state->{entries}{$entry};
394 if ( defined ( $state->{prependdir} ) )
396 $log->debug("Prepending '$state->{prependdir}' to state|directory");
397 $state->{directory} = $state->{prependdir} . $state->{directory}
399 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
402 # Entry entry-line \n
403 # Response expected: no. Tell the server what version of a file is on the
404 # local machine. The name in entry-line is a name relative to the directory
405 # most recently specified with Directory. If the user is operating on only
406 # some files in a directory, Entry requests for only those files need be
407 # included. If an Entry request is sent without Modified, Is-modified, or
408 # Unchanged, it means the file is lost (does not exist in the working
409 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
410 # are sent for the same file, Entry must be sent first. For a given file,
411 # one can send Modified, Is-modified, or Unchanged, but not more than one
412 # of these three.
413 sub req_Entry
415 my ( $cmd, $data ) = @_;
417 #$log->debug("req_Entry : $data");
419 my @data = split(/\//, $data);
421 $state->{entries}{$state->{directory}.$data[1]} = {
422 revision => $data[2],
423 conflict => $data[3],
424 options => $data[4],
425 tag_or_date => $data[5],
428 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
431 # Questionable filename \n
432 # Response expected: no. Additional data: no. Tell the server to check
433 # whether filename should be ignored, and if not, next time the server
434 # sends responses, send (in a M response) `?' followed by the directory and
435 # filename. filename must not contain `/'; it needs to be a file in the
436 # directory named by the most recent Directory request.
437 sub req_Questionable
439 my ( $cmd, $data ) = @_;
441 $log->debug("req_Questionable : $data");
442 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
445 # add \n
446 # Response expected: yes. Add a file or directory. This uses any previous
447 # Argument, Directory, Entry, or Modified requests, if they have been sent.
448 # The last Directory sent specifies the working directory at the time of
449 # the operation. To add a directory, send the directory to be added using
450 # Directory and Argument requests.
451 sub req_add
453 my ( $cmd, $data ) = @_;
455 argsplit("add");
457 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
458 $updater->update();
460 argsfromdir($updater);
462 my $addcount = 0;
464 foreach my $filename ( @{$state->{args}} )
466 $filename = filecleanup($filename);
468 my $meta = $updater->getmeta($filename);
469 my $wrev = revparse($filename);
471 if ($wrev && $meta && ($wrev < 0))
473 # previously removed file, add back
474 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
476 print "MT +updated\n";
477 print "MT text U \n";
478 print "MT fname $filename\n";
479 print "MT newline\n";
480 print "MT -updated\n";
482 unless ( $state->{globaloptions}{-n} )
484 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
486 print "Created $dirpart\n";
487 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
489 # this is an "entries" line
490 my $kopts = kopts_from_path($filepart);
491 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
492 print "/$filepart/1.$meta->{revision}//$kopts/\n";
493 # permissions
494 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
495 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
496 # transmit file
497 transmitfile($meta->{filehash});
500 next;
503 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
505 print "E cvs add: nothing known about `$filename'\n";
506 next;
508 # TODO : check we're not squashing an already existing file
509 if ( defined ( $state->{entries}{$filename}{revision} ) )
511 print "E cvs add: `$filename' has already been entered\n";
512 next;
515 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
517 print "E cvs add: scheduling file `$filename' for addition\n";
519 print "Checked-in $dirpart\n";
520 print "$filename\n";
521 my $kopts = kopts_from_path($filepart);
522 print "/$filepart/0//$kopts/\n";
524 $addcount++;
527 if ( $addcount == 1 )
529 print "E cvs add: use `cvs commit' to add this file permanently\n";
531 elsif ( $addcount > 1 )
533 print "E cvs add: use `cvs commit' to add these files permanently\n";
536 print "ok\n";
539 # remove \n
540 # Response expected: yes. Remove a file. This uses any previous Argument,
541 # Directory, Entry, or Modified requests, if they have been sent. The last
542 # Directory sent specifies the working directory at the time of the
543 # operation. Note that this request does not actually do anything to the
544 # repository; the only effect of a successful remove request is to supply
545 # the client with a new entries line containing `-' to indicate a removed
546 # file. In fact, the client probably could perform this operation without
547 # contacting the server, although using remove may cause the server to
548 # perform a few more checks. The client sends a subsequent ci request to
549 # actually record the removal in the repository.
550 sub req_remove
552 my ( $cmd, $data ) = @_;
554 argsplit("remove");
556 # Grab a handle to the SQLite db and do any necessary updates
557 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
558 $updater->update();
560 #$log->debug("add state : " . Dumper($state));
562 my $rmcount = 0;
564 foreach my $filename ( @{$state->{args}} )
566 $filename = filecleanup($filename);
568 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
570 print "E cvs remove: file `$filename' still in working directory\n";
571 next;
574 my $meta = $updater->getmeta($filename);
575 my $wrev = revparse($filename);
577 unless ( defined ( $wrev ) )
579 print "E cvs remove: nothing known about `$filename'\n";
580 next;
583 if ( defined($wrev) and $wrev < 0 )
585 print "E cvs remove: file `$filename' already scheduled for removal\n";
586 next;
589 unless ( $wrev == $meta->{revision} )
591 # TODO : not sure if the format of this message is quite correct.
592 print "E cvs remove: Up to date check failed for `$filename'\n";
593 next;
597 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
599 print "E cvs remove: scheduling `$filename' for removal\n";
601 print "Checked-in $dirpart\n";
602 print "$filename\n";
603 my $kopts = kopts_from_path($filepart);
604 print "/$filepart/-1.$wrev//$kopts/\n";
606 $rmcount++;
609 if ( $rmcount == 1 )
611 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
613 elsif ( $rmcount > 1 )
615 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
618 print "ok\n";
621 # Modified filename \n
622 # Response expected: no. Additional data: mode, \n, file transmission. Send
623 # the server a copy of one locally modified file. filename is a file within
624 # the most recent directory sent with Directory; it must not contain `/'.
625 # If the user is operating on only some files in a directory, only those
626 # files need to be included. This can also be sent without Entry, if there
627 # is no entry for the file.
628 sub req_Modified
630 my ( $cmd, $data ) = @_;
632 my $mode = <STDIN>;
633 defined $mode
634 or (print "E end of file reading mode for $data\n"), return;
635 chomp $mode;
636 my $size = <STDIN>;
637 defined $size
638 or (print "E end of file reading size of $data\n"), return;
639 chomp $size;
641 # Grab config information
642 my $blocksize = 8192;
643 my $bytesleft = $size;
644 my $tmp;
646 # Get a filehandle/name to write it to
647 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
649 # Loop over file data writing out to temporary file.
650 while ( $bytesleft )
652 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
653 read STDIN, $tmp, $blocksize;
654 print $fh $tmp;
655 $bytesleft -= $blocksize;
658 close $fh
659 or (print "E failed to write temporary, $filename: $!\n"), return;
661 # Ensure we have something sensible for the file mode
662 if ( $mode =~ /u=(\w+)/ )
664 $mode = $1;
665 } else {
666 $mode = "rw";
669 # Save the file data in $state
670 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
671 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
672 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
673 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
675 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
678 # Unchanged filename \n
679 # Response expected: no. Tell the server that filename has not been
680 # modified in the checked out directory. The filename is a file within the
681 # most recent directory sent with Directory; it must not contain `/'.
682 sub req_Unchanged
684 my ( $cmd, $data ) = @_;
686 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
688 #$log->debug("req_Unchanged : $data");
691 # Argument text \n
692 # Response expected: no. Save argument for use in a subsequent command.
693 # Arguments accumulate until an argument-using command is given, at which
694 # point they are forgotten.
695 # Argumentx text \n
696 # Response expected: no. Append \n followed by text to the current argument
697 # being saved.
698 sub req_Argument
700 my ( $cmd, $data ) = @_;
702 # Argumentx means: append to last Argument (with a newline in front)
704 $log->debug("$cmd : $data");
706 if ( $cmd eq 'Argumentx') {
707 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
708 } else {
709 push @{$state->{arguments}}, $data;
713 # expand-modules \n
714 # Response expected: yes. Expand the modules which are specified in the
715 # arguments. Returns the data in Module-expansion responses. Note that the
716 # server can assume that this is checkout or export, not rtag or rdiff; the
717 # latter do not access the working directory and thus have no need to
718 # expand modules on the client side. Expand may not be the best word for
719 # what this request does. It does not necessarily tell you all the files
720 # contained in a module, for example. Basically it is a way of telling you
721 # which working directories the server needs to know about in order to
722 # handle a checkout of the specified modules. For example, suppose that the
723 # server has a module defined by
724 # aliasmodule -a 1dir
725 # That is, one can check out aliasmodule and it will take 1dir in the
726 # repository and check it out to 1dir in the working directory. Now suppose
727 # the client already has this module checked out and is planning on using
728 # the co request to update it. Without using expand-modules, the client
729 # would have two bad choices: it could either send information about all
730 # working directories under the current directory, which could be
731 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
732 # stands for 1dir, and neglect to send information for 1dir, which would
733 # lead to incorrect operation. With expand-modules, the client would first
734 # ask for the module to be expanded:
735 sub req_expandmodules
737 my ( $cmd, $data ) = @_;
739 argsplit();
741 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
743 unless ( ref $state->{arguments} eq "ARRAY" )
745 print "ok\n";
746 return;
749 foreach my $module ( @{$state->{arguments}} )
751 $log->debug("SEND : Module-expansion $module");
752 print "Module-expansion $module\n";
755 print "ok\n";
756 statecleanup();
759 # co \n
760 # Response expected: yes. Get files from the repository. This uses any
761 # previous Argument, Directory, Entry, or Modified requests, if they have
762 # been sent. Arguments to this command are module names; the client cannot
763 # know what directories they correspond to except by (1) just sending the
764 # co request, and then seeing what directory names the server sends back in
765 # its responses, and (2) the expand-modules request.
766 sub req_co
768 my ( $cmd, $data ) = @_;
770 argsplit("co");
772 my $module = $state->{args}[0];
773 my $checkout_path = $module;
775 # use the user specified directory if we're given it
776 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
778 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
780 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
782 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
784 # Grab a handle to the SQLite db and do any necessary updates
785 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
786 $updater->update();
788 $checkout_path =~ s|/$||; # get rid of trailing slashes
790 # Eclipse seems to need the Clear-sticky command
791 # to prepare the 'Entries' file for the new directory.
792 print "Clear-sticky $checkout_path/\n";
793 print $state->{CVSROOT} . "/$module/\n";
794 print "Clear-static-directory $checkout_path/\n";
795 print $state->{CVSROOT} . "/$module/\n";
796 print "Clear-sticky $checkout_path/\n"; # yes, twice
797 print $state->{CVSROOT} . "/$module/\n";
798 print "Template $checkout_path/\n";
799 print $state->{CVSROOT} . "/$module/\n";
800 print "0\n";
802 # instruct the client that we're checking out to $checkout_path
803 print "E cvs checkout: Updating $checkout_path\n";
805 my %seendirs = ();
806 my $lastdir ='';
808 # recursive
809 sub prepdir {
810 my ($dir, $repodir, $remotedir, $seendirs) = @_;
811 my $parent = dirname($dir);
812 $dir =~ s|/+$||;
813 $repodir =~ s|/+$||;
814 $remotedir =~ s|/+$||;
815 $parent =~ s|/+$||;
816 $log->debug("announcedir $dir, $repodir, $remotedir" );
818 if ($parent eq '.' || $parent eq './') {
819 $parent = '';
821 # recurse to announce unseen parents first
822 if (length($parent) && !exists($seendirs->{$parent})) {
823 prepdir($parent, $repodir, $remotedir, $seendirs);
825 # Announce that we are going to modify at the parent level
826 if ($parent) {
827 print "E cvs checkout: Updating $remotedir/$parent\n";
828 } else {
829 print "E cvs checkout: Updating $remotedir\n";
831 print "Clear-sticky $remotedir/$parent/\n";
832 print "$repodir/$parent/\n";
834 print "Clear-static-directory $remotedir/$dir/\n";
835 print "$repodir/$dir/\n";
836 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
837 print "$repodir/$parent/\n";
838 print "Template $remotedir/$dir/\n";
839 print "$repodir/$dir/\n";
840 print "0\n";
842 $seendirs->{$dir} = 1;
845 foreach my $git ( @{$updater->gethead} )
847 # Don't want to check out deleted files
848 next if ( $git->{filehash} eq "deleted" );
850 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
852 if (length($git->{dir}) && $git->{dir} ne './'
853 && $git->{dir} ne $lastdir ) {
854 unless (exists($seendirs{$git->{dir}})) {
855 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
856 $checkout_path, \%seendirs);
857 $lastdir = $git->{dir};
858 $seendirs{$git->{dir}} = 1;
860 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
863 # modification time of this file
864 print "Mod-time $git->{modified}\n";
866 # print some information to the client
867 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
869 print "M U $checkout_path/$git->{dir}$git->{name}\n";
870 } else {
871 print "M U $checkout_path/$git->{name}\n";
874 # instruct client we're sending a file to put in this path
875 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
877 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
879 # this is an "entries" line
880 my $kopts = kopts_from_path($git->{name});
881 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
882 # permissions
883 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
885 # transmit file
886 transmitfile($git->{filehash});
889 print "ok\n";
891 statecleanup();
894 # update \n
895 # Response expected: yes. Actually do a cvs update command. This uses any
896 # previous Argument, Directory, Entry, or Modified requests, if they have
897 # been sent. The last Directory sent specifies the working directory at the
898 # time of the operation. The -I option is not used--files which the client
899 # can decide whether to ignore are not mentioned and the client sends the
900 # Questionable request for others.
901 sub req_update
903 my ( $cmd, $data ) = @_;
905 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
907 argsplit("update");
910 # It may just be a client exploring the available heads/modules
911 # in that case, list them as top level directories and leave it
912 # at that. Eclipse uses this technique to offer you a list of
913 # projects (heads in this case) to checkout.
915 if ($state->{module} eq '') {
916 my $heads_dir = $state->{CVSROOT} . '/refs/heads';
917 if (!opendir HEADS, $heads_dir) {
918 print "E [server aborted]: Failed to open directory, "
919 . "$heads_dir: $!\nerror\n";
920 return 0;
922 print "E cvs update: Updating .\n";
923 while (my $head = readdir(HEADS)) {
924 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
925 print "E cvs update: New directory `$head'\n";
928 closedir HEADS;
929 print "ok\n";
930 return 1;
934 # Grab a handle to the SQLite db and do any necessary updates
935 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
937 $updater->update();
939 argsfromdir($updater);
941 #$log->debug("update state : " . Dumper($state));
943 # foreach file specified on the command line ...
944 foreach my $filename ( @{$state->{args}} )
946 $filename = filecleanup($filename);
948 $log->debug("Processing file $filename");
950 # if we have a -C we should pretend we never saw modified stuff
951 if ( exists ( $state->{opt}{C} ) )
953 delete $state->{entries}{$filename}{modified_hash};
954 delete $state->{entries}{$filename}{modified_filename};
955 $state->{entries}{$filename}{unchanged} = 1;
958 my $meta;
959 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
961 $meta = $updater->getmeta($filename, $1);
962 } else {
963 $meta = $updater->getmeta($filename);
966 # If -p was given, "print" the contents of the requested revision.
967 if ( exists ( $state->{opt}{p} ) ) {
968 if ( defined ( $meta->{revision} ) ) {
969 $log->info("Printing '$filename' revision " . $meta->{revision});
971 transmitfile($meta->{filehash}, { print => 1 });
974 next;
977 if ( ! defined $meta )
979 $meta = {
980 name => $filename,
981 revision => 0,
982 filehash => 'added'
986 my $oldmeta = $meta;
988 my $wrev = revparse($filename);
990 # If the working copy is an old revision, lets get that version too for comparison.
991 if ( defined($wrev) and $wrev != $meta->{revision} )
993 $oldmeta = $updater->getmeta($filename, $wrev);
996 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
998 # Files are up to date if the working copy and repo copy have the same revision,
999 # and the working copy is unmodified _and_ the user hasn't specified -C
1000 next if ( defined ( $wrev )
1001 and defined($meta->{revision})
1002 and $wrev == $meta->{revision}
1003 and $state->{entries}{$filename}{unchanged}
1004 and not exists ( $state->{opt}{C} ) );
1006 # If the working copy and repo copy have the same revision,
1007 # but the working copy is modified, tell the client it's modified
1008 if ( defined ( $wrev )
1009 and defined($meta->{revision})
1010 and $wrev == $meta->{revision}
1011 and defined($state->{entries}{$filename}{modified_hash})
1012 and not exists ( $state->{opt}{C} ) )
1014 $log->info("Tell the client the file is modified");
1015 print "MT text M \n";
1016 print "MT fname $filename\n";
1017 print "MT newline\n";
1018 next;
1021 if ( $meta->{filehash} eq "deleted" )
1023 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1025 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1027 print "E cvs update: `$filename' is no longer in the repository\n";
1028 # Don't want to actually _DO_ the update if -n specified
1029 unless ( $state->{globaloptions}{-n} ) {
1030 print "Removed $dirpart\n";
1031 print "$filepart\n";
1034 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1035 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1036 or $meta->{filehash} eq 'added' )
1038 # normal update, just send the new revision (either U=Update,
1039 # or A=Add, or R=Remove)
1040 if ( defined($wrev) && $wrev < 0 )
1042 $log->info("Tell the client the file is scheduled for removal");
1043 print "MT text R \n";
1044 print "MT fname $filename\n";
1045 print "MT newline\n";
1046 next;
1048 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1050 $log->info("Tell the client the file is scheduled for addition");
1051 print "MT text A \n";
1052 print "MT fname $filename\n";
1053 print "MT newline\n";
1054 next;
1057 else {
1058 $log->info("Updating '$filename' to ".$meta->{revision});
1059 print "MT +updated\n";
1060 print "MT text U \n";
1061 print "MT fname $filename\n";
1062 print "MT newline\n";
1063 print "MT -updated\n";
1066 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1068 # Don't want to actually _DO_ the update if -n specified
1069 unless ( $state->{globaloptions}{-n} )
1071 if ( defined ( $wrev ) )
1073 # instruct client we're sending a file to put in this path as a replacement
1074 print "Update-existing $dirpart\n";
1075 $log->debug("Updating existing file 'Update-existing $dirpart'");
1076 } else {
1077 # instruct client we're sending a file to put in this path as a new file
1078 print "Clear-static-directory $dirpart\n";
1079 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1080 print "Clear-sticky $dirpart\n";
1081 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1083 $log->debug("Creating new file 'Created $dirpart'");
1084 print "Created $dirpart\n";
1086 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1088 # this is an "entries" line
1089 my $kopts = kopts_from_path($filepart);
1090 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1091 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1093 # permissions
1094 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1095 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1097 # transmit file
1098 transmitfile($meta->{filehash});
1100 } else {
1101 $log->info("Updating '$filename'");
1102 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1104 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
1106 chdir $dir;
1107 my $file_local = $filepart . ".mine";
1108 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1109 my $file_old = $filepart . "." . $oldmeta->{revision};
1110 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1111 my $file_new = $filepart . "." . $meta->{revision};
1112 transmitfile($meta->{filehash}, { targetfile => $file_new });
1114 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1115 $log->info("Merging $file_local, $file_old, $file_new");
1116 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1118 $log->debug("Temporary directory for merge is $dir");
1120 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1121 $return >>= 8;
1123 if ( $return == 0 )
1125 $log->info("Merged successfully");
1126 print "M M $filename\n";
1127 $log->debug("Merged $dirpart");
1129 # Don't want to actually _DO_ the update if -n specified
1130 unless ( $state->{globaloptions}{-n} )
1132 print "Merged $dirpart\n";
1133 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1134 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1135 my $kopts = kopts_from_path($filepart);
1136 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1137 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1140 elsif ( $return == 1 )
1142 $log->info("Merged with conflicts");
1143 print "E cvs update: conflicts found in $filename\n";
1144 print "M C $filename\n";
1146 # Don't want to actually _DO_ the update if -n specified
1147 unless ( $state->{globaloptions}{-n} )
1149 print "Merged $dirpart\n";
1150 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1151 my $kopts = kopts_from_path($filepart);
1152 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1155 else
1157 $log->warn("Merge failed");
1158 next;
1161 # Don't want to actually _DO_ the update if -n specified
1162 unless ( $state->{globaloptions}{-n} )
1164 # permissions
1165 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1166 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1168 # transmit file, format is single integer on a line by itself (file
1169 # size) followed by the file contents
1170 # TODO : we should copy files in blocks
1171 my $data = `cat $file_local`;
1172 $log->debug("File size : " . length($data));
1173 print length($data) . "\n";
1174 print $data;
1177 chdir "/";
1182 print "ok\n";
1185 sub req_ci
1187 my ( $cmd, $data ) = @_;
1189 argsplit("ci");
1191 #$log->debug("State : " . Dumper($state));
1193 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1195 if ( $state->{method} eq 'pserver')
1197 print "error 1 pserver access cannot commit\n";
1198 exit;
1201 if ( -e $state->{CVSROOT} . "/index" )
1203 $log->warn("file 'index' already exists in the git repository");
1204 print "error 1 Index already exists in git repo\n";
1205 exit;
1208 # Grab a handle to the SQLite db and do any necessary updates
1209 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1210 $updater->update();
1212 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1213 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1214 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1216 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1217 $ENV{GIT_WORK_TREE} = ".";
1218 $ENV{GIT_INDEX_FILE} = $file_index;
1220 # Remember where the head was at the beginning.
1221 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1222 chomp $parenthash;
1223 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1224 print "error 1 pserver cannot find the current HEAD of module";
1225 exit;
1228 chdir $tmpdir;
1230 # populate the temporary index
1231 system("git-read-tree", $parenthash);
1232 unless ($? == 0)
1234 die "Error running git-read-tree $state->{module} $file_index $!";
1236 $log->info("Created index '$file_index' for head $state->{module} - exit status $?");
1238 my @committedfiles = ();
1239 my %oldmeta;
1241 # foreach file specified on the command line ...
1242 foreach my $filename ( @{$state->{args}} )
1244 my $committedfile = $filename;
1245 $filename = filecleanup($filename);
1247 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1249 my $meta = $updater->getmeta($filename);
1250 $oldmeta{$filename} = $meta;
1252 my $wrev = revparse($filename);
1254 my ( $filepart, $dirpart ) = filenamesplit($filename);
1256 # do a checkout of the file if it is part of this tree
1257 if ($wrev) {
1258 system('git-checkout-index', '-f', '-u', $filename);
1259 unless ($? == 0) {
1260 die "Error running git-checkout-index -f -u $filename : $!";
1264 my $addflag = 0;
1265 my $rmflag = 0;
1266 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1267 $addflag = 1 unless ( -e $filename );
1269 # Do up to date checking
1270 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1272 # fail everything if an up to date check fails
1273 print "error 1 Up to date check failed for $filename\n";
1274 chdir "/";
1275 exit;
1278 push @committedfiles, $committedfile;
1279 $log->info("Committing $filename");
1281 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1283 unless ( $rmflag )
1285 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1286 rename $state->{entries}{$filename}{modified_filename},$filename;
1288 # Calculate modes to remove
1289 my $invmode = "";
1290 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1292 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1293 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1296 if ( $rmflag )
1298 $log->info("Removing file '$filename'");
1299 unlink($filename);
1300 system("git-update-index", "--remove", $filename);
1302 elsif ( $addflag )
1304 $log->info("Adding file '$filename'");
1305 system("git-update-index", "--add", $filename);
1306 } else {
1307 $log->info("Updating file '$filename'");
1308 system("git-update-index", $filename);
1312 unless ( scalar(@committedfiles) > 0 )
1314 print "E No files to commit\n";
1315 print "ok\n";
1316 chdir "/";
1317 return;
1320 my $treehash = `git-write-tree`;
1321 chomp $treehash;
1323 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1325 # write our commit message out if we have one ...
1326 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1327 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1328 print $msg_fh "\n\nvia git-CVS emulator\n";
1329 close $msg_fh;
1331 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1332 chomp($commithash);
1333 $log->info("Commit hash : $commithash");
1335 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1337 $log->warn("Commit failed (Invalid commit hash)");
1338 print "error 1 Commit failed (unknown reason)\n";
1339 chdir "/";
1340 exit;
1343 ### Emulate git-receive-pack by running hooks/update
1344 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1345 $parenthash, $commithash );
1346 if( -x $hook[0] ) {
1347 unless( system( @hook ) == 0 )
1349 $log->warn("Commit failed (update hook declined to update ref)");
1350 print "error 1 Commit failed (update hook declined)\n";
1351 chdir "/";
1352 exit;
1356 ### Update the ref
1357 if (system(qw(git update-ref -m), "cvsserver ci",
1358 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1359 $log->warn("update-ref for $state->{module} failed.");
1360 print "error 1 Cannot commit -- update first\n";
1361 exit;
1364 ### Emulate git-receive-pack by running hooks/post-receive
1365 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1366 if( -x $hook ) {
1367 open(my $pipe, "| $hook") || die "can't fork $!";
1369 local $SIG{PIPE} = sub { die 'pipe broke' };
1371 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1373 close $pipe || die "bad pipe: $! $?";
1376 ### Then hooks/post-update
1377 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1378 if (-x $hook) {
1379 system($hook, "refs/heads/$state->{module}");
1382 $updater->update();
1384 # foreach file specified on the command line ...
1385 foreach my $filename ( @committedfiles )
1387 $filename = filecleanup($filename);
1389 my $meta = $updater->getmeta($filename);
1390 unless (defined $meta->{revision}) {
1391 $meta->{revision} = 1;
1394 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1396 $log->debug("Checked-in $dirpart : $filename");
1398 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1399 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1401 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1402 print "Remove-entry $dirpart\n";
1403 print "$filename\n";
1404 } else {
1405 if ($meta->{revision} == 1) {
1406 print "M initial revision: 1.1\n";
1407 } else {
1408 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1410 print "Checked-in $dirpart\n";
1411 print "$filename\n";
1412 my $kopts = kopts_from_path($filepart);
1413 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1417 chdir "/";
1418 print "ok\n";
1421 sub req_status
1423 my ( $cmd, $data ) = @_;
1425 argsplit("status");
1427 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1428 #$log->debug("status state : " . Dumper($state));
1430 # Grab a handle to the SQLite db and do any necessary updates
1431 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1432 $updater->update();
1434 # if no files were specified, we need to work out what files we should be providing status on ...
1435 argsfromdir($updater);
1437 # foreach file specified on the command line ...
1438 foreach my $filename ( @{$state->{args}} )
1440 $filename = filecleanup($filename);
1442 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1444 my $meta = $updater->getmeta($filename);
1445 my $oldmeta = $meta;
1447 my $wrev = revparse($filename);
1449 # If the working copy is an old revision, lets get that version too for comparison.
1450 if ( defined($wrev) and $wrev != $meta->{revision} )
1452 $oldmeta = $updater->getmeta($filename, $wrev);
1455 # TODO : All possible statuses aren't yet implemented
1456 my $status;
1457 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1458 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1460 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1461 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1464 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1465 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1467 ( $state->{entries}{$filename}{unchanged}
1468 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1471 # Need checkout if it exists in the repo but doesn't have a working copy
1472 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1474 # Locally modified if working copy and repo copy have the same revision but there are local changes
1475 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1477 # Needs Merge if working copy revision is less than repo copy and there are local changes
1478 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1480 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1481 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1482 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1483 $status ||= "File had conflicts on merge" if ( 0 );
1485 $status ||= "Unknown";
1487 my ($filepart) = filenamesplit($filename);
1489 print "M ===================================================================\n";
1490 print "M File: $filepart\tStatus: $status\n";
1491 if ( defined($state->{entries}{$filename}{revision}) )
1493 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1494 } else {
1495 print "M Working revision:\tNo entry for $filename\n";
1497 if ( defined($meta->{revision}) )
1499 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1500 print "M Sticky Tag:\t\t(none)\n";
1501 print "M Sticky Date:\t\t(none)\n";
1502 print "M Sticky Options:\t\t(none)\n";
1503 } else {
1504 print "M Repository revision:\tNo revision control file\n";
1506 print "M\n";
1509 print "ok\n";
1512 sub req_diff
1514 my ( $cmd, $data ) = @_;
1516 argsplit("diff");
1518 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1519 #$log->debug("status state : " . Dumper($state));
1521 my ($revision1, $revision2);
1522 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1524 $revision1 = $state->{opt}{r}[0];
1525 $revision2 = $state->{opt}{r}[1];
1526 } else {
1527 $revision1 = $state->{opt}{r};
1530 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1531 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1533 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1535 # Grab a handle to the SQLite db and do any necessary updates
1536 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1537 $updater->update();
1539 # if no files were specified, we need to work out what files we should be providing status on ...
1540 argsfromdir($updater);
1542 # foreach file specified on the command line ...
1543 foreach my $filename ( @{$state->{args}} )
1545 $filename = filecleanup($filename);
1547 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1549 my $wrev = revparse($filename);
1551 # We need _something_ to diff against
1552 next unless ( defined ( $wrev ) );
1554 # if we have a -r switch, use it
1555 if ( defined ( $revision1 ) )
1557 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1558 $meta1 = $updater->getmeta($filename, $revision1);
1559 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1561 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1562 next;
1564 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1566 # otherwise we just use the working copy revision
1567 else
1569 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1570 $meta1 = $updater->getmeta($filename, $wrev);
1571 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1574 # if we have a second -r switch, use it too
1575 if ( defined ( $revision2 ) )
1577 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1578 $meta2 = $updater->getmeta($filename, $revision2);
1580 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1582 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1583 next;
1586 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1588 # otherwise we just use the working copy
1589 else
1591 $file2 = $state->{entries}{$filename}{modified_filename};
1594 # if we have been given -r, and we don't have a $file2 yet, lets get one
1595 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1597 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1598 $meta2 = $updater->getmeta($filename, $wrev);
1599 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1602 # We need to have retrieved something useful
1603 next unless ( defined ( $meta1 ) );
1605 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1606 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1608 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1609 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1612 # Apparently we only show diffs for locally modified files
1613 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1615 print "M Index: $filename\n";
1616 print "M ===================================================================\n";
1617 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1618 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1619 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1620 print "M diff ";
1621 foreach my $opt ( keys %{$state->{opt}} )
1623 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1625 foreach my $value ( @{$state->{opt}{$opt}} )
1627 print "-$opt $value ";
1629 } else {
1630 print "-$opt ";
1631 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1634 print "$filename\n";
1636 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1638 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1640 if ( exists $state->{opt}{u} )
1642 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1643 } else {
1644 system("diff $file1 $file2 > $filediff");
1647 while ( <$fh> )
1649 print "M $_";
1651 close $fh;
1654 print "ok\n";
1657 sub req_log
1659 my ( $cmd, $data ) = @_;
1661 argsplit("log");
1663 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1664 #$log->debug("log state : " . Dumper($state));
1666 my ( $minrev, $maxrev );
1667 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1669 my $control = $2;
1670 $minrev = $1;
1671 $maxrev = $3;
1672 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1673 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1674 $minrev++ if ( defined($minrev) and $control eq "::" );
1677 # Grab a handle to the SQLite db and do any necessary updates
1678 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1679 $updater->update();
1681 # if no files were specified, we need to work out what files we should be providing status on ...
1682 argsfromdir($updater);
1684 # foreach file specified on the command line ...
1685 foreach my $filename ( @{$state->{args}} )
1687 $filename = filecleanup($filename);
1689 my $headmeta = $updater->getmeta($filename);
1691 my $revisions = $updater->getlog($filename);
1692 my $totalrevisions = scalar(@$revisions);
1694 if ( defined ( $minrev ) )
1696 $log->debug("Removing revisions less than $minrev");
1697 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1699 pop @$revisions;
1702 if ( defined ( $maxrev ) )
1704 $log->debug("Removing revisions greater than $maxrev");
1705 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1707 shift @$revisions;
1711 next unless ( scalar(@$revisions) );
1713 print "M \n";
1714 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1715 print "M Working file: $filename\n";
1716 print "M head: 1.$headmeta->{revision}\n";
1717 print "M branch:\n";
1718 print "M locks: strict\n";
1719 print "M access list:\n";
1720 print "M symbolic names:\n";
1721 print "M keyword substitution: kv\n";
1722 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1723 print "M description:\n";
1725 foreach my $revision ( @$revisions )
1727 print "M ----------------------------\n";
1728 print "M revision 1.$revision->{revision}\n";
1729 # reformat the date for log output
1730 $revision->{modified} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1731 $revision->{author} = cvs_author($revision->{author});
1732 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1733 my $commitmessage = $updater->commitmessage($revision->{commithash});
1734 $commitmessage =~ s/^/M /mg;
1735 print $commitmessage . "\n";
1737 print "M =============================================================================\n";
1740 print "ok\n";
1743 sub req_annotate
1745 my ( $cmd, $data ) = @_;
1747 argsplit("annotate");
1749 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1750 #$log->debug("status state : " . Dumper($state));
1752 # Grab a handle to the SQLite db and do any necessary updates
1753 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1754 $updater->update();
1756 # if no files were specified, we need to work out what files we should be providing annotate on ...
1757 argsfromdir($updater);
1759 # we'll need a temporary checkout dir
1760 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1761 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1762 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1764 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1765 $ENV{GIT_WORK_TREE} = ".";
1766 $ENV{GIT_INDEX_FILE} = $file_index;
1768 chdir $tmpdir;
1770 # foreach file specified on the command line ...
1771 foreach my $filename ( @{$state->{args}} )
1773 $filename = filecleanup($filename);
1775 my $meta = $updater->getmeta($filename);
1777 next unless ( $meta->{revision} );
1779 # get all the commits that this file was in
1780 # in dense format -- aka skip dead revisions
1781 my $revisions = $updater->gethistorydense($filename);
1782 my $lastseenin = $revisions->[0][2];
1784 # populate the temporary index based on the latest commit were we saw
1785 # the file -- but do it cheaply without checking out any files
1786 # TODO: if we got a revision from the client, use that instead
1787 # to look up the commithash in sqlite (still good to default to
1788 # the current head as we do now)
1789 system("git-read-tree", $lastseenin);
1790 unless ($? == 0)
1792 print "E error running git-read-tree $lastseenin $file_index $!\n";
1793 return;
1795 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1797 # do a checkout of the file
1798 system('git-checkout-index', '-f', '-u', $filename);
1799 unless ($? == 0) {
1800 print "E error running git-checkout-index -f -u $filename : $!\n";
1801 return;
1804 $log->info("Annotate $filename");
1806 # Prepare a file with the commits from the linearized
1807 # history that annotate should know about. This prevents
1808 # git-jsannotate telling us about commits we are hiding
1809 # from the client.
1811 my $a_hints = "$tmpdir/.annotate_hints";
1812 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1813 print "E failed to open '$a_hints' for writing: $!\n";
1814 return;
1816 for (my $i=0; $i < @$revisions; $i++)
1818 print ANNOTATEHINTS $revisions->[$i][2];
1819 if ($i+1 < @$revisions) { # have we got a parent?
1820 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1822 print ANNOTATEHINTS "\n";
1825 print ANNOTATEHINTS "\n";
1826 close ANNOTATEHINTS
1827 or (print "E failed to write $a_hints: $!\n"), return;
1829 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1830 if (!open(ANNOTATE, "-|", @cmd)) {
1831 print "E error invoking ". join(' ',@cmd) .": $!\n";
1832 return;
1834 my $metadata = {};
1835 print "E Annotations for $filename\n";
1836 print "E ***************\n";
1837 while ( <ANNOTATE> )
1839 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1841 my $commithash = $1;
1842 my $data = $2;
1843 unless ( defined ( $metadata->{$commithash} ) )
1845 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1846 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1847 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1849 printf("M 1.%-5d (%-8s %10s): %s\n",
1850 $metadata->{$commithash}{revision},
1851 $metadata->{$commithash}{author},
1852 $metadata->{$commithash}{modified},
1853 $data
1855 } else {
1856 $log->warn("Error in annotate output! LINE: $_");
1857 print "E Annotate error \n";
1858 next;
1861 close ANNOTATE;
1864 # done; get out of the tempdir
1865 chdir "/";
1867 print "ok\n";
1871 # This method takes the state->{arguments} array and produces two new arrays.
1872 # The first is $state->{args} which is everything before the '--' argument, and
1873 # the second is $state->{files} which is everything after it.
1874 sub argsplit
1876 $state->{args} = [];
1877 $state->{files} = [];
1878 $state->{opt} = {};
1880 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1882 my $type = shift;
1884 if ( defined($type) )
1886 my $opt = {};
1887 $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" );
1888 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1889 $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" );
1890 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1891 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1892 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1893 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1894 $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" );
1897 while ( scalar ( @{$state->{arguments}} ) > 0 )
1899 my $arg = shift @{$state->{arguments}};
1901 next if ( $arg eq "--" );
1902 next unless ( $arg =~ /\S/ );
1904 # if the argument looks like a switch
1905 if ( $arg =~ /^-(\w)(.*)/ )
1907 # if it's a switch that takes an argument
1908 if ( $opt->{$1} )
1910 # If this switch has already been provided
1911 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1913 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1914 if ( length($2) > 0 )
1916 push @{$state->{opt}{$1}},$2;
1917 } else {
1918 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1920 } else {
1921 # if there's extra data in the arg, use that as the argument for the switch
1922 if ( length($2) > 0 )
1924 $state->{opt}{$1} = $2;
1925 } else {
1926 $state->{opt}{$1} = shift @{$state->{arguments}};
1929 } else {
1930 $state->{opt}{$1} = undef;
1933 else
1935 push @{$state->{args}}, $arg;
1939 else
1941 my $mode = 0;
1943 foreach my $value ( @{$state->{arguments}} )
1945 if ( $value eq "--" )
1947 $mode++;
1948 next;
1950 push @{$state->{args}}, $value if ( $mode == 0 );
1951 push @{$state->{files}}, $value if ( $mode == 1 );
1956 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1957 sub argsfromdir
1959 my $updater = shift;
1961 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1963 return if ( scalar ( @{$state->{args}} ) > 1 );
1965 my @gethead = @{$updater->gethead};
1967 # push added files
1968 foreach my $file (keys %{$state->{entries}}) {
1969 if ( exists $state->{entries}{$file}{revision} &&
1970 $state->{entries}{$file}{revision} == 0 )
1972 push @gethead, { name => $file, filehash => 'added' };
1976 if ( scalar(@{$state->{args}}) == 1 )
1978 my $arg = $state->{args}[0];
1979 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1981 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1983 foreach my $file ( @gethead )
1985 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1986 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1987 push @{$state->{args}}, $file->{name};
1990 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1991 } else {
1992 $log->info("Only one arg specified, populating file list automatically");
1994 $state->{args} = [];
1996 foreach my $file ( @gethead )
1998 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1999 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2000 push @{$state->{args}}, $file->{name};
2005 # This method cleans up the $state variable after a command that uses arguments has run
2006 sub statecleanup
2008 $state->{files} = [];
2009 $state->{args} = [];
2010 $state->{arguments} = [];
2011 $state->{entries} = {};
2014 sub revparse
2016 my $filename = shift;
2018 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2020 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2021 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2023 return undef;
2026 # This method takes a file hash and does a CVS "file transfer". Its
2027 # exact behaviour depends on a second, optional hash table argument:
2028 # - If $options->{targetfile}, dump the contents to that file;
2029 # - If $options->{print}, use M/MT to transmit the contents one line
2030 # at a time;
2031 # - Otherwise, transmit the size of the file, followed by the file
2032 # contents.
2033 sub transmitfile
2035 my $filehash = shift;
2036 my $options = shift;
2038 if ( defined ( $filehash ) and $filehash eq "deleted" )
2040 $log->warn("filehash is 'deleted'");
2041 return;
2044 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2046 my $type = `git-cat-file -t $filehash`;
2047 chomp $type;
2049 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2051 my $size = `git-cat-file -s $filehash`;
2052 chomp $size;
2054 $log->debug("transmitfile($filehash) size=$size, type=$type");
2056 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2058 if ( defined ( $options->{targetfile} ) )
2060 my $targetfile = $options->{targetfile};
2061 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2062 print NEWFILE $_ while ( <$fh> );
2063 close NEWFILE or die("Failed to write '$targetfile': $!");
2064 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2065 while ( <$fh> ) {
2066 if( /\n\z/ ) {
2067 print 'M ', $_;
2068 } else {
2069 print 'MT text ', $_, "\n";
2072 } else {
2073 print "$size\n";
2074 print while ( <$fh> );
2076 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2077 } else {
2078 die("Couldn't execute git-cat-file");
2082 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2083 # refers to the directory portion and the file portion of the filename
2084 # respectively
2085 sub filenamesplit
2087 my $filename = shift;
2088 my $fixforlocaldir = shift;
2090 my ( $filepart, $dirpart ) = ( $filename, "." );
2091 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2092 $dirpart .= "/";
2094 if ( $fixforlocaldir )
2096 $dirpart =~ s/^$state->{prependdir}//;
2099 return ( $filepart, $dirpart );
2102 sub filecleanup
2104 my $filename = shift;
2106 return undef unless(defined($filename));
2107 if ( $filename =~ /^\// )
2109 print "E absolute filenames '$filename' not supported by server\n";
2110 return undef;
2113 $filename =~ s/^\.\///g;
2114 $filename = $state->{prependdir} . $filename;
2115 return $filename;
2118 # Given a path, this function returns a string containing the kopts
2119 # that should go into that path's Entries line. For example, a binary
2120 # file should get -kb.
2121 sub kopts_from_path
2123 my ($path) = @_;
2125 # Once it exists, the git attributes system should be used to look up
2126 # what attributes apply to this path.
2128 # Until then, take the setting from the config file
2129 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
2131 # Return "" to give no special treatment to any path
2132 return "";
2133 } else {
2134 # Alternatively, to have all files treated as if they are binary (which
2135 # is more like git itself), always return the "-kb" option
2136 return "-kb";
2140 # Generate a CVS author name from Git author information, by taking
2141 # the first eight characters of the user part of the email address.
2142 sub cvs_author
2144 my $author_line = shift;
2145 (my $author) = $author_line =~ /<([^>@]{1,8})/;
2147 $author;
2150 package GITCVS::log;
2152 ####
2153 #### Copyright The Open University UK - 2006.
2154 ####
2155 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2156 #### Martin Langhoff <martin@catalyst.net.nz>
2157 ####
2158 ####
2160 use strict;
2161 use warnings;
2163 =head1 NAME
2165 GITCVS::log
2167 =head1 DESCRIPTION
2169 This module provides very crude logging with a similar interface to
2170 Log::Log4perl
2172 =head1 METHODS
2174 =cut
2176 =head2 new
2178 Creates a new log object, optionally you can specify a filename here to
2179 indicate the file to log to. If no log file is specified, you can specify one
2180 later with method setfile, or indicate you no longer want logging with method
2181 nofile.
2183 Until one of these methods is called, all log calls will buffer messages ready
2184 to write out.
2186 =cut
2187 sub new
2189 my $class = shift;
2190 my $filename = shift;
2192 my $self = {};
2194 bless $self, $class;
2196 if ( defined ( $filename ) )
2198 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2201 return $self;
2204 =head2 setfile
2206 This methods takes a filename, and attempts to open that file as the log file.
2207 If successful, all buffered data is written out to the file, and any further
2208 logging is written directly to the file.
2210 =cut
2211 sub setfile
2213 my $self = shift;
2214 my $filename = shift;
2216 if ( defined ( $filename ) )
2218 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2221 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2223 while ( my $line = shift @{$self->{buffer}} )
2225 print {$self->{fh}} $line;
2229 =head2 nofile
2231 This method indicates no logging is going to be used. It flushes any entries in
2232 the internal buffer, and sets a flag to ensure no further data is put there.
2234 =cut
2235 sub nofile
2237 my $self = shift;
2239 $self->{nolog} = 1;
2241 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2243 $self->{buffer} = [];
2246 =head2 _logopen
2248 Internal method. Returns true if the log file is open, false otherwise.
2250 =cut
2251 sub _logopen
2253 my $self = shift;
2255 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2256 return 0;
2259 =head2 debug info warn fatal
2261 These four methods are wrappers to _log. They provide the actual interface for
2262 logging data.
2264 =cut
2265 sub debug { my $self = shift; $self->_log("debug", @_); }
2266 sub info { my $self = shift; $self->_log("info" , @_); }
2267 sub warn { my $self = shift; $self->_log("warn" , @_); }
2268 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2270 =head2 _log
2272 This is an internal method called by the logging functions. It generates a
2273 timestamp and pushes the logged line either to file, or internal buffer.
2275 =cut
2276 sub _log
2278 my $self = shift;
2279 my $level = shift;
2281 return if ( $self->{nolog} );
2283 my @time = localtime;
2284 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2285 $time[5] + 1900,
2286 $time[4] + 1,
2287 $time[3],
2288 $time[2],
2289 $time[1],
2290 $time[0],
2291 uc $level,
2294 if ( $self->_logopen )
2296 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2297 } else {
2298 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2302 =head2 DESTROY
2304 This method simply closes the file handle if one is open
2306 =cut
2307 sub DESTROY
2309 my $self = shift;
2311 if ( $self->_logopen )
2313 close $self->{fh};
2317 package GITCVS::updater;
2319 ####
2320 #### Copyright The Open University UK - 2006.
2321 ####
2322 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2323 #### Martin Langhoff <martin@catalyst.net.nz>
2324 ####
2325 ####
2327 use strict;
2328 use warnings;
2329 use DBI;
2331 =head1 METHODS
2333 =cut
2335 =head2 new
2337 =cut
2338 sub new
2340 my $class = shift;
2341 my $config = shift;
2342 my $module = shift;
2343 my $log = shift;
2345 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2346 die "Need to specify a module" unless ( defined($module) );
2348 $class = ref($class) || $class;
2350 my $self = {};
2352 bless $self, $class;
2354 $self->{valid_tables} = {'revision' => 1,
2355 'revision_ix1' => 1,
2356 'revision_ix2' => 1,
2357 'head' => 1,
2358 'head_ix1' => 1,
2359 'properties' => 1,
2360 'commitmsgs' => 1};
2362 $self->{module} = $module;
2363 $self->{git_path} = $config . "/";
2365 $self->{log} = $log;
2367 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2369 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2370 $cfg->{gitcvs}{dbdriver} || "SQLite";
2371 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2372 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2373 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2374 $cfg->{gitcvs}{dbuser} || "";
2375 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2376 $cfg->{gitcvs}{dbpass} || "";
2377 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2378 $cfg->{gitcvs}{dbtablenameprefix} || "";
2379 my %mapping = ( m => $module,
2380 a => $state->{method},
2381 u => getlogin || getpwuid($<) || $<,
2382 G => $self->{git_path},
2383 g => mangle_dirname($self->{git_path}),
2385 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2386 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2387 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2388 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2390 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2391 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2392 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2393 $self->{dbuser},
2394 $self->{dbpass});
2395 die "Error connecting to database\n" unless defined $self->{dbh};
2397 $self->{tables} = {};
2398 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2400 $self->{tables}{$table} = 1;
2403 # Construct the revision table if required
2404 unless ( $self->{tables}{$self->tablename("revision")} )
2406 my $tablename = $self->tablename("revision");
2407 my $ix1name = $self->tablename("revision_ix1");
2408 my $ix2name = $self->tablename("revision_ix2");
2409 $self->{dbh}->do("
2410 CREATE TABLE $tablename (
2411 name TEXT NOT NULL,
2412 revision INTEGER NOT NULL,
2413 filehash TEXT NOT NULL,
2414 commithash TEXT NOT NULL,
2415 author TEXT NOT NULL,
2416 modified TEXT NOT NULL,
2417 mode TEXT NOT NULL
2420 $self->{dbh}->do("
2421 CREATE INDEX $ix1name
2422 ON $tablename (name,revision)
2424 $self->{dbh}->do("
2425 CREATE INDEX $ix2name
2426 ON $tablename (name,commithash)
2430 # Construct the head table if required
2431 unless ( $self->{tables}{$self->tablename("head")} )
2433 my $tablename = $self->tablename("head");
2434 my $ix1name = $self->tablename("head_ix1");
2435 $self->{dbh}->do("
2436 CREATE TABLE $tablename (
2437 name TEXT NOT NULL,
2438 revision INTEGER NOT NULL,
2439 filehash TEXT NOT NULL,
2440 commithash TEXT NOT NULL,
2441 author TEXT NOT NULL,
2442 modified TEXT NOT NULL,
2443 mode TEXT NOT NULL
2446 $self->{dbh}->do("
2447 CREATE INDEX $ix1name
2448 ON $tablename (name)
2452 # Construct the properties table if required
2453 unless ( $self->{tables}{$self->tablename("properties")} )
2455 my $tablename = $self->tablename("properties");
2456 $self->{dbh}->do("
2457 CREATE TABLE $tablename (
2458 key TEXT NOT NULL PRIMARY KEY,
2459 value TEXT
2464 # Construct the commitmsgs table if required
2465 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2467 my $tablename = $self->tablename("commitmsgs");
2468 $self->{dbh}->do("
2469 CREATE TABLE $tablename (
2470 key TEXT NOT NULL PRIMARY KEY,
2471 value TEXT
2476 return $self;
2479 =head2 tablename
2481 =cut
2482 sub tablename
2484 my $self = shift;
2485 my $name = shift;
2487 if (exists $self->{valid_tables}{$name}) {
2488 return $self->{dbtablenameprefix} . $name;
2489 } else {
2490 return undef;
2494 =head2 update
2496 =cut
2497 sub update
2499 my $self = shift;
2501 # first lets get the commit list
2502 $ENV{GIT_DIR} = $self->{git_path};
2504 my $commitsha1 = `git rev-parse $self->{module}`;
2505 chomp $commitsha1;
2507 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2508 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2510 die("Invalid module '$self->{module}'");
2514 my $git_log;
2515 my $lastcommit = $self->_get_prop("last_commit");
2517 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2518 return 1;
2521 # Start exclusive lock here...
2522 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2524 # TODO: log processing is memory bound
2525 # if we can parse into a 2nd file that is in reverse order
2526 # we can probably do something really efficient
2527 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2529 if (defined $lastcommit) {
2530 push @git_log_params, "$lastcommit..$self->{module}";
2531 } else {
2532 push @git_log_params, $self->{module};
2534 # git-rev-list is the backend / plumbing version of git-log
2535 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2537 my @commits;
2539 my %commit = ();
2541 while ( <GITLOG> )
2543 chomp;
2544 if (m/^commit\s+(.*)$/) {
2545 # on ^commit lines put the just seen commit in the stack
2546 # and prime things for the next one
2547 if (keys %commit) {
2548 my %copy = %commit;
2549 unshift @commits, \%copy;
2550 %commit = ();
2552 my @parents = split(m/\s+/, $1);
2553 $commit{hash} = shift @parents;
2554 $commit{parents} = \@parents;
2555 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2556 # on rfc822-like lines seen before we see any message,
2557 # lowercase the entry and put it in the hash as key-value
2558 $commit{lc($1)} = $2;
2559 } else {
2560 # message lines - skip initial empty line
2561 # and trim whitespace
2562 if (!exists($commit{message}) && m/^\s*$/) {
2563 # define it to mark the end of headers
2564 $commit{message} = '';
2565 next;
2567 s/^\s+//; s/\s+$//; # trim ws
2568 $commit{message} .= $_ . "\n";
2571 close GITLOG;
2573 unshift @commits, \%commit if ( keys %commit );
2575 # Now all the commits are in the @commits bucket
2576 # ordered by time DESC. for each commit that needs processing,
2577 # determine whether it's following the last head we've seen or if
2578 # it's on its own branch, grab a file list, and add whatever's changed
2579 # NOTE: $lastcommit refers to the last commit from previous run
2580 # $lastpicked is the last commit we picked in this run
2581 my $lastpicked;
2582 my $head = {};
2583 if (defined $lastcommit) {
2584 $lastpicked = $lastcommit;
2587 my $committotal = scalar(@commits);
2588 my $commitcount = 0;
2590 # Load the head table into $head (for cached lookups during the update process)
2591 foreach my $file ( @{$self->gethead()} )
2593 $head->{$file->{name}} = $file;
2596 foreach my $commit ( @commits )
2598 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2599 if (defined $lastpicked)
2601 if (!in_array($lastpicked, @{$commit->{parents}}))
2603 # skip, we'll see this delta
2604 # as part of a merge later
2605 # warn "skipping off-track $commit->{hash}\n";
2606 next;
2607 } elsif (@{$commit->{parents}} > 1) {
2608 # it is a merge commit, for each parent that is
2609 # not $lastpicked, see if we can get a log
2610 # from the merge-base to that parent to put it
2611 # in the message as a merge summary.
2612 my @parents = @{$commit->{parents}};
2613 foreach my $parent (@parents) {
2614 # git-merge-base can potentially (but rarely) throw
2615 # several candidate merge bases. let's assume
2616 # that the first one is the best one.
2617 if ($parent eq $lastpicked) {
2618 next;
2620 my $base = eval {
2621 safe_pipe_capture('git-merge-base',
2622 $lastpicked, $parent);
2624 # The two branches may not be related at all,
2625 # in which case merge base simply fails to find
2626 # any, but that's Ok.
2627 next if ($@);
2629 chomp $base;
2630 if ($base) {
2631 my @merged;
2632 # print "want to log between $base $parent \n";
2633 open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
2634 or die "Cannot call git-log: $!";
2635 my $mergedhash;
2636 while (<GITLOG>) {
2637 chomp;
2638 if (!defined $mergedhash) {
2639 if (m/^commit\s+(.+)$/) {
2640 $mergedhash = $1;
2641 } else {
2642 next;
2644 } else {
2645 # grab the first line that looks non-rfc822
2646 # aka has content after leading space
2647 if (m/^\s+(\S.*)$/) {
2648 my $title = $1;
2649 $title = substr($title,0,100); # truncate
2650 unshift @merged, "$mergedhash $title";
2651 undef $mergedhash;
2655 close GITLOG;
2656 if (@merged) {
2657 $commit->{mergemsg} = $commit->{message};
2658 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2659 foreach my $summary (@merged) {
2660 $commit->{mergemsg} .= "\t$summary\n";
2662 $commit->{mergemsg} .= "\n\n";
2663 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2670 # convert the date to CVS-happy format
2671 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2673 if ( defined ( $lastpicked ) )
2675 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2676 local ($/) = "\0";
2677 while ( <FILELIST> )
2679 chomp;
2680 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2682 die("Couldn't process git-diff-tree line : $_");
2684 my ($mode, $hash, $change) = ($1, $2, $3);
2685 my $name = <FILELIST>;
2686 chomp($name);
2688 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2690 my $git_perms = "";
2691 $git_perms .= "r" if ( $mode & 4 );
2692 $git_perms .= "w" if ( $mode & 2 );
2693 $git_perms .= "x" if ( $mode & 1 );
2694 $git_perms = "rw" if ( $git_perms eq "" );
2696 if ( $change eq "D" )
2698 #$log->debug("DELETE $name");
2699 $head->{$name} = {
2700 name => $name,
2701 revision => $head->{$name}{revision} + 1,
2702 filehash => "deleted",
2703 commithash => $commit->{hash},
2704 modified => $commit->{date},
2705 author => $commit->{author},
2706 mode => $git_perms,
2708 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2710 elsif ( $change eq "M" || $change eq "T" )
2712 #$log->debug("MODIFIED $name");
2713 $head->{$name} = {
2714 name => $name,
2715 revision => $head->{$name}{revision} + 1,
2716 filehash => $hash,
2717 commithash => $commit->{hash},
2718 modified => $commit->{date},
2719 author => $commit->{author},
2720 mode => $git_perms,
2722 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2724 elsif ( $change eq "A" )
2726 #$log->debug("ADDED $name");
2727 $head->{$name} = {
2728 name => $name,
2729 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
2730 filehash => $hash,
2731 commithash => $commit->{hash},
2732 modified => $commit->{date},
2733 author => $commit->{author},
2734 mode => $git_perms,
2736 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2738 else
2740 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2741 die;
2744 close FILELIST;
2745 } else {
2746 # this is used to detect files removed from the repo
2747 my $seen_files = {};
2749 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2750 local $/ = "\0";
2751 while ( <FILELIST> )
2753 chomp;
2754 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2756 die("Couldn't process git-ls-tree line : $_");
2759 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2761 $seen_files->{$git_filename} = 1;
2763 my ( $oldhash, $oldrevision, $oldmode ) = (
2764 $head->{$git_filename}{filehash},
2765 $head->{$git_filename}{revision},
2766 $head->{$git_filename}{mode}
2769 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2771 $git_perms = "";
2772 $git_perms .= "r" if ( $1 & 4 );
2773 $git_perms .= "w" if ( $1 & 2 );
2774 $git_perms .= "x" if ( $1 & 1 );
2775 } else {
2776 $git_perms = "rw";
2779 # unless the file exists with the same hash, we need to update it ...
2780 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2782 my $newrevision = ( $oldrevision or 0 ) + 1;
2784 $head->{$git_filename} = {
2785 name => $git_filename,
2786 revision => $newrevision,
2787 filehash => $git_hash,
2788 commithash => $commit->{hash},
2789 modified => $commit->{date},
2790 author => $commit->{author},
2791 mode => $git_perms,
2795 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2798 close FILELIST;
2800 # Detect deleted files
2801 foreach my $file ( keys %$head )
2803 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2805 $head->{$file}{revision}++;
2806 $head->{$file}{filehash} = "deleted";
2807 $head->{$file}{commithash} = $commit->{hash};
2808 $head->{$file}{modified} = $commit->{date};
2809 $head->{$file}{author} = $commit->{author};
2811 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2814 # END : "Detect deleted files"
2818 if (exists $commit->{mergemsg})
2820 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2823 $lastpicked = $commit->{hash};
2825 $self->_set_prop("last_commit", $commit->{hash});
2828 $self->delete_head();
2829 foreach my $file ( keys %$head )
2831 $self->insert_head(
2832 $file,
2833 $head->{$file}{revision},
2834 $head->{$file}{filehash},
2835 $head->{$file}{commithash},
2836 $head->{$file}{modified},
2837 $head->{$file}{author},
2838 $head->{$file}{mode},
2841 # invalidate the gethead cache
2842 $self->{gethead_cache} = undef;
2845 # Ending exclusive lock here
2846 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2849 sub insert_rev
2851 my $self = shift;
2852 my $name = shift;
2853 my $revision = shift;
2854 my $filehash = shift;
2855 my $commithash = shift;
2856 my $modified = shift;
2857 my $author = shift;
2858 my $mode = shift;
2859 my $tablename = $self->tablename("revision");
2861 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2862 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2865 sub insert_mergelog
2867 my $self = shift;
2868 my $key = shift;
2869 my $value = shift;
2870 my $tablename = $self->tablename("commitmsgs");
2872 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
2873 $insert_mergelog->execute($key, $value);
2876 sub delete_head
2878 my $self = shift;
2879 my $tablename = $self->tablename("head");
2881 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
2882 $delete_head->execute();
2885 sub insert_head
2887 my $self = shift;
2888 my $name = shift;
2889 my $revision = shift;
2890 my $filehash = shift;
2891 my $commithash = shift;
2892 my $modified = shift;
2893 my $author = shift;
2894 my $mode = shift;
2895 my $tablename = $self->tablename("head");
2897 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2898 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2901 sub _headrev
2903 my $self = shift;
2904 my $filename = shift;
2905 my $tablename = $self->tablename("head");
2907 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
2908 $db_query->execute($filename);
2909 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2911 return ( $hash, $revision, $mode );
2914 sub _get_prop
2916 my $self = shift;
2917 my $key = shift;
2918 my $tablename = $self->tablename("properties");
2920 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
2921 $db_query->execute($key);
2922 my ( $value ) = $db_query->fetchrow_array;
2924 return $value;
2927 sub _set_prop
2929 my $self = shift;
2930 my $key = shift;
2931 my $value = shift;
2932 my $tablename = $self->tablename("properties");
2934 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
2935 $db_query->execute($value, $key);
2937 unless ( $db_query->rows )
2939 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
2940 $db_query->execute($key, $value);
2943 return $value;
2946 =head2 gethead
2948 =cut
2950 sub gethead
2952 my $self = shift;
2953 my $tablename = $self->tablename("head");
2955 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2957 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
2958 $db_query->execute();
2960 my $tree = [];
2961 while ( my $file = $db_query->fetchrow_hashref )
2963 push @$tree, $file;
2966 $self->{gethead_cache} = $tree;
2968 return $tree;
2971 =head2 getlog
2973 =cut
2975 sub getlog
2977 my $self = shift;
2978 my $filename = shift;
2979 my $tablename = $self->tablename("revision");
2981 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
2982 $db_query->execute($filename);
2984 my $tree = [];
2985 while ( my $file = $db_query->fetchrow_hashref )
2987 push @$tree, $file;
2990 return $tree;
2993 =head2 getmeta
2995 This function takes a filename (with path) argument and returns a hashref of
2996 metadata for that file.
2998 =cut
3000 sub getmeta
3002 my $self = shift;
3003 my $filename = shift;
3004 my $revision = shift;
3005 my $tablename_rev = $self->tablename("revision");
3006 my $tablename_head = $self->tablename("head");
3008 my $db_query;
3009 if ( defined($revision) and $revision =~ /^\d+$/ )
3011 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3012 $db_query->execute($filename, $revision);
3014 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3016 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3017 $db_query->execute($filename, $revision);
3018 } else {
3019 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3020 $db_query->execute($filename);
3023 return $db_query->fetchrow_hashref;
3026 =head2 commitmessage
3028 this function takes a commithash and returns the commit message for that commit
3030 =cut
3031 sub commitmessage
3033 my $self = shift;
3034 my $commithash = shift;
3035 my $tablename = $self->tablename("commitmsgs");
3037 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3039 my $db_query;
3040 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3041 $db_query->execute($commithash);
3043 my ( $message ) = $db_query->fetchrow_array;
3045 if ( defined ( $message ) )
3047 $message .= " " if ( $message =~ /\n$/ );
3048 return $message;
3051 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3052 shift @lines while ( $lines[0] =~ /\S/ );
3053 $message = join("",@lines);
3054 $message .= " " if ( $message =~ /\n$/ );
3055 return $message;
3058 =head2 gethistory
3060 This function takes a filename (with path) argument and returns an arrayofarrays
3061 containing revision,filehash,commithash ordered by revision descending
3063 =cut
3064 sub gethistory
3066 my $self = shift;
3067 my $filename = shift;
3068 my $tablename = $self->tablename("revision");
3070 my $db_query;
3071 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3072 $db_query->execute($filename);
3074 return $db_query->fetchall_arrayref;
3077 =head2 gethistorydense
3079 This function takes a filename (with path) argument and returns an arrayofarrays
3080 containing revision,filehash,commithash ordered by revision descending.
3082 This version of gethistory skips deleted entries -- so it is useful for annotate.
3083 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3084 and other git tools that depend on it.
3086 =cut
3087 sub gethistorydense
3089 my $self = shift;
3090 my $filename = shift;
3091 my $tablename = $self->tablename("revision");
3093 my $db_query;
3094 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3095 $db_query->execute($filename);
3097 return $db_query->fetchall_arrayref;
3100 =head2 in_array()
3102 from Array::PAT - mimics the in_array() function
3103 found in PHP. Yuck but works for small arrays.
3105 =cut
3106 sub in_array
3108 my ($check, @array) = @_;
3109 my $retval = 0;
3110 foreach my $test (@array){
3111 if($check eq $test){
3112 $retval = 1;
3115 return $retval;
3118 =head2 safe_pipe_capture
3120 an alternative to `command` that allows input to be passed as an array
3121 to work around shell problems with weird characters in arguments
3123 =cut
3124 sub safe_pipe_capture {
3126 my @output;
3128 if (my $pid = open my $child, '-|') {
3129 @output = (<$child>);
3130 close $child or die join(' ',@_).": $! $?";
3131 } else {
3132 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3134 return wantarray ? @output : join('',@output);
3137 =head2 mangle_dirname
3139 create a string from a directory name that is suitable to use as
3140 part of a filename, mainly by converting all chars except \w.- to _
3142 =cut
3143 sub mangle_dirname {
3144 my $dirname = shift;
3145 return unless defined $dirname;
3147 $dirname =~ s/[^\w.-]/_/g;
3149 return $dirname;
3152 =head2 mangle_tablename
3154 create a string from a that is suitable to use as part of an SQL table
3155 name, mainly by converting all chars except \w to _
3157 =cut
3158 sub mangle_tablename {
3159 my $tablename = shift;
3160 return unless defined $tablename;
3162 $tablename =~ s/[^\w_]/_/g;
3164 return $tablename;