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",
45 };
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_CATCHALL,
77 'editors' => \&req_CATCHALL,
78 'annotate' => \&req_annotate,
79 'Global_option' => \&req_Globaloption,
80 #'annotate' => \&req_CATCHALL,
81 };
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;
111 }
112 if ($state->{help}) {
113 print $usage;
114 exit;
115 }
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;
127 }
128 }
130 # everything else is a directory
131 $state->{allowed_roots} = [ @ARGV ];
133 # if we are called with a pserver argument,
134 # deal with the authentication cat before entering the
135 # main loop
136 if ($state->{method} eq 'pserver') {
137 my $line = <STDIN>; chomp $line;
138 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
139 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
140 }
141 my $request = $1;
142 $line = <STDIN>; chomp $line;
143 req_Root('root', $line) # reuse Root
144 or die "E Invalid root $line \n";
145 $line = <STDIN>; chomp $line;
146 unless ($line eq 'anonymous') {
147 print "E Only anonymous user allowed via pserver\n";
148 print "I HATE YOU\n";
149 exit 1;
150 }
151 $line = <STDIN>; chomp $line; # validate the password?
152 $line = <STDIN>; chomp $line;
153 unless ($line eq "END $request REQUEST") {
154 die "E Do not understand $line -- expecting END $request REQUEST\n";
155 }
156 print "I LOVE YOU\n";
157 exit if $request eq 'VERIFICATION'; # cvs login
158 # and now back to our regular programme...
159 }
161 # Keep going until the client closes the connection
162 while (<STDIN>)
163 {
164 chomp;
166 # Check to see if we've seen this method, and call appropriate function.
167 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
168 {
169 # use the $methods hash to call the appropriate sub for this command
170 #$log->info("Method : $1");
171 &{$methods->{$1}}($1,$2);
172 } else {
173 # log fatal because we don't understand this function. If this happens
174 # we're fairly screwed because we don't know if the client is expecting
175 # a response. If it is, the client will hang, we'll hang, and the whole
176 # thing will be custard.
177 $log->fatal("Don't understand command $_\n");
178 die("Unknown command $_");
179 }
180 }
182 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
183 $log->info("--------------- FINISH -----------------");
185 # Magic catchall method.
186 # This is the method that will handle all commands we haven't yet
187 # implemented. It simply sends a warning to the log file indicating a
188 # command that hasn't been implemented has been invoked.
189 sub req_CATCHALL
190 {
191 my ( $cmd, $data ) = @_;
192 $log->warn("Unhandled command : req_$cmd : $data");
193 }
196 # Root pathname \n
197 # Response expected: no. Tell the server which CVSROOT to use. Note that
198 # pathname is a local directory and not a fully qualified CVSROOT variable.
199 # pathname must already exist; if creating a new root, use the init
200 # request, not Root. pathname does not include the hostname of the server,
201 # how to access the server, etc.; by the time the CVS protocol is in use,
202 # connection, authentication, etc., are already taken care of. The Root
203 # request must be sent only once, and it must be sent before any requests
204 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
205 sub req_Root
206 {
207 my ( $cmd, $data ) = @_;
208 $log->debug("req_Root : $data");
210 unless ($data =~ m#^/#) {
211 print "error 1 Root must be an absolute pathname\n";
212 return 0;
213 }
215 if ($state->{CVSROOT}
216 && ($state->{CVSROOT} ne $data)) {
217 print "error 1 Conflicting roots specified\n";
218 return 0;
219 }
221 $state->{CVSROOT} = $state->{'base-path'} || '';
222 $state->{CVSROOT} =~ s#/+$##;
223 $state->{CVSROOT} .= $data;
225 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
227 if (@{$state->{allowed_roots}}) {
228 my $allowed = 0;
229 foreach my $dir (@{$state->{allowed_roots}}) {
230 next unless $dir =~ m#^/#;
231 $dir =~ s#/+$##;
232 if ($state->{'strict-paths'}) {
233 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
234 $allowed = 1;
235 last;
236 }
237 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
238 $allowed = 1;
239 last;
240 }
241 }
243 unless ($allowed) {
244 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
245 print "E \n";
246 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
247 return 0;
248 }
249 }
251 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
252 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
253 print "E \n";
254 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
255 return 0;
256 }
258 my @gitvars = `git-config -l`;
259 if ($?) {
260 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
261 print "E \n";
262 print "error 1 - problem executing git-config\n";
263 return 0;
264 }
265 foreach my $line ( @gitvars )
266 {
267 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
268 unless ($2) {
269 $cfg->{$1}{$3} = $4;
270 } else {
271 $cfg->{$1}{$2}{$3} = $4;
272 }
273 }
275 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
276 || $cfg->{gitcvs}{enabled});
277 unless ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i) {
278 print "E GITCVS emulation needs to be enabled on this repo\n";
279 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
280 print "E \n";
281 print "error 1 GITCVS emulation disabled\n";
282 return 0;
283 }
285 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
286 if ( $logfile )
287 {
288 $log->setfile($logfile);
289 } else {
290 $log->nofile();
291 }
293 return 1;
294 }
296 # Global_option option \n
297 # Response expected: no. Transmit one of the global options `-q', `-Q',
298 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
299 # variations (such as combining of options) are allowed. For graceful
300 # handling of valid-requests, it is probably better to make new global
301 # options separate requests, rather than trying to add them to this
302 # request.
303 sub req_Globaloption
304 {
305 my ( $cmd, $data ) = @_;
306 $log->debug("req_Globaloption : $data");
307 $state->{globaloptions}{$data} = 1;
308 }
310 # Valid-responses request-list \n
311 # Response expected: no. Tell the server what responses the client will
312 # accept. request-list is a space separated list of tokens.
313 sub req_Validresponses
314 {
315 my ( $cmd, $data ) = @_;
316 $log->debug("req_Validresponses : $data");
318 # TODO : re-enable this, currently it's not particularly useful
319 #$state->{validresponses} = [ split /\s+/, $data ];
320 }
322 # valid-requests \n
323 # Response expected: yes. Ask the server to send back a Valid-requests
324 # response.
325 sub req_validrequests
326 {
327 my ( $cmd, $data ) = @_;
329 $log->debug("req_validrequests");
331 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
332 $log->debug("SEND : ok");
334 print "Valid-requests " . join(" ",keys %$methods) . "\n";
335 print "ok\n";
336 }
338 # Directory local-directory \n
339 # Additional data: repository \n. Response expected: no. Tell the server
340 # what directory to use. The repository should be a directory name from a
341 # previous server response. Note that this both gives a default for Entry
342 # and Modified and also for ci and the other commands; normal usage is to
343 # send Directory for each directory in which there will be an Entry or
344 # Modified, and then a final Directory for the original directory, then the
345 # command. The local-directory is relative to the top level at which the
346 # command is occurring (i.e. the last Directory which is sent before the
347 # command); to indicate that top level, `.' should be sent for
348 # local-directory.
349 sub req_Directory
350 {
351 my ( $cmd, $data ) = @_;
353 my $repository = <STDIN>;
354 chomp $repository;
357 $state->{localdir} = $data;
358 $state->{repository} = $repository;
359 $state->{path} = $repository;
360 $state->{path} =~ s/^$state->{CVSROOT}\///;
361 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
362 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
364 $state->{directory} = $state->{localdir};
365 $state->{directory} = "" if ( $state->{directory} eq "." );
366 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
368 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
369 {
370 $log->info("Setting prepend to '$state->{path}'");
371 $state->{prependdir} = $state->{path};
372 foreach my $entry ( keys %{$state->{entries}} )
373 {
374 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
375 delete $state->{entries}{$entry};
376 }
377 }
379 if ( defined ( $state->{prependdir} ) )
380 {
381 $log->debug("Prepending '$state->{prependdir}' to state|directory");
382 $state->{directory} = $state->{prependdir} . $state->{directory}
383 }
384 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
385 }
387 # Entry entry-line \n
388 # Response expected: no. Tell the server what version of a file is on the
389 # local machine. The name in entry-line is a name relative to the directory
390 # most recently specified with Directory. If the user is operating on only
391 # some files in a directory, Entry requests for only those files need be
392 # included. If an Entry request is sent without Modified, Is-modified, or
393 # Unchanged, it means the file is lost (does not exist in the working
394 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
395 # are sent for the same file, Entry must be sent first. For a given file,
396 # one can send Modified, Is-modified, or Unchanged, but not more than one
397 # of these three.
398 sub req_Entry
399 {
400 my ( $cmd, $data ) = @_;
402 #$log->debug("req_Entry : $data");
404 my @data = split(/\//, $data);
406 $state->{entries}{$state->{directory}.$data[1]} = {
407 revision => $data[2],
408 conflict => $data[3],
409 options => $data[4],
410 tag_or_date => $data[5],
411 };
413 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
414 }
416 # Questionable filename \n
417 # Response expected: no. Additional data: no. Tell the server to check
418 # whether filename should be ignored, and if not, next time the server
419 # sends responses, send (in a M response) `?' followed by the directory and
420 # filename. filename must not contain `/'; it needs to be a file in the
421 # directory named by the most recent Directory request.
422 sub req_Questionable
423 {
424 my ( $cmd, $data ) = @_;
426 $log->debug("req_Questionable : $data");
427 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
428 }
430 # add \n
431 # Response expected: yes. Add a file or directory. This uses any previous
432 # Argument, Directory, Entry, or Modified requests, if they have been sent.
433 # The last Directory sent specifies the working directory at the time of
434 # the operation. To add a directory, send the directory to be added using
435 # Directory and Argument requests.
436 sub req_add
437 {
438 my ( $cmd, $data ) = @_;
440 argsplit("add");
442 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
443 $updater->update();
445 argsfromdir($updater);
447 my $addcount = 0;
449 foreach my $filename ( @{$state->{args}} )
450 {
451 $filename = filecleanup($filename);
453 my $meta = $updater->getmeta($filename);
454 my $wrev = revparse($filename);
456 if ($wrev && $meta && ($wrev < 0))
457 {
458 # previously removed file, add back
459 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
461 print "MT +updated\n";
462 print "MT text U \n";
463 print "MT fname $filename\n";
464 print "MT newline\n";
465 print "MT -updated\n";
467 unless ( $state->{globaloptions}{-n} )
468 {
469 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
471 print "Created $dirpart\n";
472 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
474 # this is an "entries" line
475 my $kopts = kopts_from_path($filepart);
476 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
477 print "/$filepart/1.$meta->{revision}//$kopts/\n";
478 # permissions
479 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
480 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
481 # transmit file
482 transmitfile($meta->{filehash});
483 }
485 next;
486 }
488 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
489 {
490 print "E cvs add: nothing known about `$filename'\n";
491 next;
492 }
493 # TODO : check we're not squashing an already existing file
494 if ( defined ( $state->{entries}{$filename}{revision} ) )
495 {
496 print "E cvs add: `$filename' has already been entered\n";
497 next;
498 }
500 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
502 print "E cvs add: scheduling file `$filename' for addition\n";
504 print "Checked-in $dirpart\n";
505 print "$filename\n";
506 my $kopts = kopts_from_path($filepart);
507 print "/$filepart/0//$kopts/\n";
509 $addcount++;
510 }
512 if ( $addcount == 1 )
513 {
514 print "E cvs add: use `cvs commit' to add this file permanently\n";
515 }
516 elsif ( $addcount > 1 )
517 {
518 print "E cvs add: use `cvs commit' to add these files permanently\n";
519 }
521 print "ok\n";
522 }
524 # remove \n
525 # Response expected: yes. Remove a file. This uses any previous Argument,
526 # Directory, Entry, or Modified requests, if they have been sent. The last
527 # Directory sent specifies the working directory at the time of the
528 # operation. Note that this request does not actually do anything to the
529 # repository; the only effect of a successful remove request is to supply
530 # the client with a new entries line containing `-' to indicate a removed
531 # file. In fact, the client probably could perform this operation without
532 # contacting the server, although using remove may cause the server to
533 # perform a few more checks. The client sends a subsequent ci request to
534 # actually record the removal in the repository.
535 sub req_remove
536 {
537 my ( $cmd, $data ) = @_;
539 argsplit("remove");
541 # Grab a handle to the SQLite db and do any necessary updates
542 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
543 $updater->update();
545 #$log->debug("add state : " . Dumper($state));
547 my $rmcount = 0;
549 foreach my $filename ( @{$state->{args}} )
550 {
551 $filename = filecleanup($filename);
553 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
554 {
555 print "E cvs remove: file `$filename' still in working directory\n";
556 next;
557 }
559 my $meta = $updater->getmeta($filename);
560 my $wrev = revparse($filename);
562 unless ( defined ( $wrev ) )
563 {
564 print "E cvs remove: nothing known about `$filename'\n";
565 next;
566 }
568 if ( defined($wrev) and $wrev < 0 )
569 {
570 print "E cvs remove: file `$filename' already scheduled for removal\n";
571 next;
572 }
574 unless ( $wrev == $meta->{revision} )
575 {
576 # TODO : not sure if the format of this message is quite correct.
577 print "E cvs remove: Up to date check failed for `$filename'\n";
578 next;
579 }
582 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
584 print "E cvs remove: scheduling `$filename' for removal\n";
586 print "Checked-in $dirpart\n";
587 print "$filename\n";
588 my $kopts = kopts_from_path($filepart);
589 print "/$filepart/-1.$wrev//$kopts/\n";
591 $rmcount++;
592 }
594 if ( $rmcount == 1 )
595 {
596 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
597 }
598 elsif ( $rmcount > 1 )
599 {
600 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
601 }
603 print "ok\n";
604 }
606 # Modified filename \n
607 # Response expected: no. Additional data: mode, \n, file transmission. Send
608 # the server a copy of one locally modified file. filename is a file within
609 # the most recent directory sent with Directory; it must not contain `/'.
610 # If the user is operating on only some files in a directory, only those
611 # files need to be included. This can also be sent without Entry, if there
612 # is no entry for the file.
613 sub req_Modified
614 {
615 my ( $cmd, $data ) = @_;
617 my $mode = <STDIN>;
618 chomp $mode;
619 my $size = <STDIN>;
620 chomp $size;
622 # Grab config information
623 my $blocksize = 8192;
624 my $bytesleft = $size;
625 my $tmp;
627 # Get a filehandle/name to write it to
628 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
630 # Loop over file data writing out to temporary file.
631 while ( $bytesleft )
632 {
633 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
634 read STDIN, $tmp, $blocksize;
635 print $fh $tmp;
636 $bytesleft -= $blocksize;
637 }
639 close $fh;
641 # Ensure we have something sensible for the file mode
642 if ( $mode =~ /u=(\w+)/ )
643 {
644 $mode = $1;
645 } else {
646 $mode = "rw";
647 }
649 # Save the file data in $state
650 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
651 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
652 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
653 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
655 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
656 }
658 # Unchanged filename \n
659 # Response expected: no. Tell the server that filename has not been
660 # modified in the checked out directory. The filename is a file within the
661 # most recent directory sent with Directory; it must not contain `/'.
662 sub req_Unchanged
663 {
664 my ( $cmd, $data ) = @_;
666 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
668 #$log->debug("req_Unchanged : $data");
669 }
671 # Argument text \n
672 # Response expected: no. Save argument for use in a subsequent command.
673 # Arguments accumulate until an argument-using command is given, at which
674 # point they are forgotten.
675 # Argumentx text \n
676 # Response expected: no. Append \n followed by text to the current argument
677 # being saved.
678 sub req_Argument
679 {
680 my ( $cmd, $data ) = @_;
682 # Argumentx means: append to last Argument (with a newline in front)
684 $log->debug("$cmd : $data");
686 if ( $cmd eq 'Argumentx') {
687 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
688 } else {
689 push @{$state->{arguments}}, $data;
690 }
691 }
693 # expand-modules \n
694 # Response expected: yes. Expand the modules which are specified in the
695 # arguments. Returns the data in Module-expansion responses. Note that the
696 # server can assume that this is checkout or export, not rtag or rdiff; the
697 # latter do not access the working directory and thus have no need to
698 # expand modules on the client side. Expand may not be the best word for
699 # what this request does. It does not necessarily tell you all the files
700 # contained in a module, for example. Basically it is a way of telling you
701 # which working directories the server needs to know about in order to
702 # handle a checkout of the specified modules. For example, suppose that the
703 # server has a module defined by
704 # aliasmodule -a 1dir
705 # That is, one can check out aliasmodule and it will take 1dir in the
706 # repository and check it out to 1dir in the working directory. Now suppose
707 # the client already has this module checked out and is planning on using
708 # the co request to update it. Without using expand-modules, the client
709 # would have two bad choices: it could either send information about all
710 # working directories under the current directory, which could be
711 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
712 # stands for 1dir, and neglect to send information for 1dir, which would
713 # lead to incorrect operation. With expand-modules, the client would first
714 # ask for the module to be expanded:
715 sub req_expandmodules
716 {
717 my ( $cmd, $data ) = @_;
719 argsplit();
721 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
723 unless ( ref $state->{arguments} eq "ARRAY" )
724 {
725 print "ok\n";
726 return;
727 }
729 foreach my $module ( @{$state->{arguments}} )
730 {
731 $log->debug("SEND : Module-expansion $module");
732 print "Module-expansion $module\n";
733 }
735 print "ok\n";
736 statecleanup();
737 }
739 # co \n
740 # Response expected: yes. Get files from the repository. This uses any
741 # previous Argument, Directory, Entry, or Modified requests, if they have
742 # been sent. Arguments to this command are module names; the client cannot
743 # know what directories they correspond to except by (1) just sending the
744 # co request, and then seeing what directory names the server sends back in
745 # its responses, and (2) the expand-modules request.
746 sub req_co
747 {
748 my ( $cmd, $data ) = @_;
750 argsplit("co");
752 my $module = $state->{args}[0];
753 my $checkout_path = $module;
755 # use the user specified directory if we're given it
756 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
758 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
760 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
762 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
764 # Grab a handle to the SQLite db and do any necessary updates
765 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
766 $updater->update();
768 $checkout_path =~ s|/$||; # get rid of trailing slashes
770 # Eclipse seems to need the Clear-sticky command
771 # to prepare the 'Entries' file for the new directory.
772 print "Clear-sticky $checkout_path/\n";
773 print $state->{CVSROOT} . "/$module/\n";
774 print "Clear-static-directory $checkout_path/\n";
775 print $state->{CVSROOT} . "/$module/\n";
776 print "Clear-sticky $checkout_path/\n"; # yes, twice
777 print $state->{CVSROOT} . "/$module/\n";
778 print "Template $checkout_path/\n";
779 print $state->{CVSROOT} . "/$module/\n";
780 print "0\n";
782 # instruct the client that we're checking out to $checkout_path
783 print "E cvs checkout: Updating $checkout_path\n";
785 my %seendirs = ();
786 my $lastdir ='';
788 # recursive
789 sub prepdir {
790 my ($dir, $repodir, $remotedir, $seendirs) = @_;
791 my $parent = dirname($dir);
792 $dir =~ s|/+$||;
793 $repodir =~ s|/+$||;
794 $remotedir =~ s|/+$||;
795 $parent =~ s|/+$||;
796 $log->debug("announcedir $dir, $repodir, $remotedir" );
798 if ($parent eq '.' || $parent eq './') {
799 $parent = '';
800 }
801 # recurse to announce unseen parents first
802 if (length($parent) && !exists($seendirs->{$parent})) {
803 prepdir($parent, $repodir, $remotedir, $seendirs);
804 }
805 # Announce that we are going to modify at the parent level
806 if ($parent) {
807 print "E cvs checkout: Updating $remotedir/$parent\n";
808 } else {
809 print "E cvs checkout: Updating $remotedir\n";
810 }
811 print "Clear-sticky $remotedir/$parent/\n";
812 print "$repodir/$parent/\n";
814 print "Clear-static-directory $remotedir/$dir/\n";
815 print "$repodir/$dir/\n";
816 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
817 print "$repodir/$parent/\n";
818 print "Template $remotedir/$dir/\n";
819 print "$repodir/$dir/\n";
820 print "0\n";
822 $seendirs->{$dir} = 1;
823 }
825 foreach my $git ( @{$updater->gethead} )
826 {
827 # Don't want to check out deleted files
828 next if ( $git->{filehash} eq "deleted" );
830 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
832 if (length($git->{dir}) && $git->{dir} ne './'
833 && $git->{dir} ne $lastdir ) {
834 unless (exists($seendirs{$git->{dir}})) {
835 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
836 $checkout_path, \%seendirs);
837 $lastdir = $git->{dir};
838 $seendirs{$git->{dir}} = 1;
839 }
840 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
841 }
843 # modification time of this file
844 print "Mod-time $git->{modified}\n";
846 # print some information to the client
847 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
848 {
849 print "M U $checkout_path/$git->{dir}$git->{name}\n";
850 } else {
851 print "M U $checkout_path/$git->{name}\n";
852 }
854 # instruct client we're sending a file to put in this path
855 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
857 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
859 # this is an "entries" line
860 my $kopts = kopts_from_path($git->{name});
861 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
862 # permissions
863 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
865 # transmit file
866 transmitfile($git->{filehash});
867 }
869 print "ok\n";
871 statecleanup();
872 }
874 # update \n
875 # Response expected: yes. Actually do a cvs update command. This uses any
876 # previous Argument, Directory, Entry, or Modified requests, if they have
877 # been sent. The last Directory sent specifies the working directory at the
878 # time of the operation. The -I option is not used--files which the client
879 # can decide whether to ignore are not mentioned and the client sends the
880 # Questionable request for others.
881 sub req_update
882 {
883 my ( $cmd, $data ) = @_;
885 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
887 argsplit("update");
889 #
890 # It may just be a client exploring the available heads/modules
891 # in that case, list them as top level directories and leave it
892 # at that. Eclipse uses this technique to offer you a list of
893 # projects (heads in this case) to checkout.
894 #
895 if ($state->{module} eq '') {
896 print "E cvs update: Updating .\n";
897 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
898 while (my $head = readdir(HEADS)) {
899 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
900 print "E cvs update: New directory `$head'\n";
901 }
902 }
903 closedir HEADS;
904 print "ok\n";
905 return 1;
906 }
909 # Grab a handle to the SQLite db and do any necessary updates
910 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
912 $updater->update();
914 argsfromdir($updater);
916 #$log->debug("update state : " . Dumper($state));
918 # foreach file specified on the command line ...
919 foreach my $filename ( @{$state->{args}} )
920 {
921 $filename = filecleanup($filename);
923 $log->debug("Processing file $filename");
925 # if we have a -C we should pretend we never saw modified stuff
926 if ( exists ( $state->{opt}{C} ) )
927 {
928 delete $state->{entries}{$filename}{modified_hash};
929 delete $state->{entries}{$filename}{modified_filename};
930 $state->{entries}{$filename}{unchanged} = 1;
931 }
933 my $meta;
934 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
935 {
936 $meta = $updater->getmeta($filename, $1);
937 } else {
938 $meta = $updater->getmeta($filename);
939 }
941 if ( ! defined $meta )
942 {
943 $meta = {
944 name => $filename,
945 revision => 0,
946 filehash => 'added'
947 };
948 }
950 my $oldmeta = $meta;
952 my $wrev = revparse($filename);
954 # If the working copy is an old revision, lets get that version too for comparison.
955 if ( defined($wrev) and $wrev != $meta->{revision} )
956 {
957 $oldmeta = $updater->getmeta($filename, $wrev);
958 }
960 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
962 # Files are up to date if the working copy and repo copy have the same revision,
963 # and the working copy is unmodified _and_ the user hasn't specified -C
964 next if ( defined ( $wrev )
965 and defined($meta->{revision})
966 and $wrev == $meta->{revision}
967 and $state->{entries}{$filename}{unchanged}
968 and not exists ( $state->{opt}{C} ) );
970 # If the working copy and repo copy have the same revision,
971 # but the working copy is modified, tell the client it's modified
972 if ( defined ( $wrev )
973 and defined($meta->{revision})
974 and $wrev == $meta->{revision}
975 and defined($state->{entries}{$filename}{modified_hash})
976 and not exists ( $state->{opt}{C} ) )
977 {
978 $log->info("Tell the client the file is modified");
979 print "MT text M \n";
980 print "MT fname $filename\n";
981 print "MT newline\n";
982 next;
983 }
985 if ( $meta->{filehash} eq "deleted" )
986 {
987 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
989 $log->info("Removing '$filename' from working copy (no longer in the repo)");
991 print "E cvs update: `$filename' is no longer in the repository\n";
992 # Don't want to actually _DO_ the update if -n specified
993 unless ( $state->{globaloptions}{-n} ) {
994 print "Removed $dirpart\n";
995 print "$filepart\n";
996 }
997 }
998 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
999 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1000 or $meta->{filehash} eq 'added' )
1001 {
1002 # normal update, just send the new revision (either U=Update,
1003 # or A=Add, or R=Remove)
1004 if ( defined($wrev) && $wrev < 0 )
1005 {
1006 $log->info("Tell the client the file is scheduled for removal");
1007 print "MT text R \n";
1008 print "MT fname $filename\n";
1009 print "MT newline\n";
1010 next;
1011 }
1012 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1013 {
1014 $log->info("Tell the client the file is scheduled for addition");
1015 print "MT text A \n";
1016 print "MT fname $filename\n";
1017 print "MT newline\n";
1018 next;
1020 }
1021 else {
1022 $log->info("Updating '$filename' to ".$meta->{revision});
1023 print "MT +updated\n";
1024 print "MT text U \n";
1025 print "MT fname $filename\n";
1026 print "MT newline\n";
1027 print "MT -updated\n";
1028 }
1030 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1032 # Don't want to actually _DO_ the update if -n specified
1033 unless ( $state->{globaloptions}{-n} )
1034 {
1035 if ( defined ( $wrev ) )
1036 {
1037 # instruct client we're sending a file to put in this path as a replacement
1038 print "Update-existing $dirpart\n";
1039 $log->debug("Updating existing file 'Update-existing $dirpart'");
1040 } else {
1041 # instruct client we're sending a file to put in this path as a new file
1042 print "Clear-static-directory $dirpart\n";
1043 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1044 print "Clear-sticky $dirpart\n";
1045 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1047 $log->debug("Creating new file 'Created $dirpart'");
1048 print "Created $dirpart\n";
1049 }
1050 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1052 # this is an "entries" line
1053 my $kopts = kopts_from_path($filepart);
1054 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1055 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1057 # permissions
1058 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1059 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1061 # transmit file
1062 transmitfile($meta->{filehash});
1063 }
1064 } else {
1065 $log->info("Updating '$filename'");
1066 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1068 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
1070 chdir $dir;
1071 my $file_local = $filepart . ".mine";
1072 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1073 my $file_old = $filepart . "." . $oldmeta->{revision};
1074 transmitfile($oldmeta->{filehash}, $file_old);
1075 my $file_new = $filepart . "." . $meta->{revision};
1076 transmitfile($meta->{filehash}, $file_new);
1078 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1079 $log->info("Merging $file_local, $file_old, $file_new");
1080 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1082 $log->debug("Temporary directory for merge is $dir");
1084 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1085 $return >>= 8;
1087 if ( $return == 0 )
1088 {
1089 $log->info("Merged successfully");
1090 print "M M $filename\n";
1091 $log->debug("Merged $dirpart");
1093 # Don't want to actually _DO_ the update if -n specified
1094 unless ( $state->{globaloptions}{-n} )
1095 {
1096 print "Merged $dirpart\n";
1097 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1098 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1099 my $kopts = kopts_from_path($filepart);
1100 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1101 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1102 }
1103 }
1104 elsif ( $return == 1 )
1105 {
1106 $log->info("Merged with conflicts");
1107 print "E cvs update: conflicts found in $filename\n";
1108 print "M C $filename\n";
1110 # Don't want to actually _DO_ the update if -n specified
1111 unless ( $state->{globaloptions}{-n} )
1112 {
1113 print "Merged $dirpart\n";
1114 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1115 my $kopts = kopts_from_path($filepart);
1116 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1117 }
1118 }
1119 else
1120 {
1121 $log->warn("Merge failed");
1122 next;
1123 }
1125 # Don't want to actually _DO_ the update if -n specified
1126 unless ( $state->{globaloptions}{-n} )
1127 {
1128 # permissions
1129 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1130 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1132 # transmit file, format is single integer on a line by itself (file
1133 # size) followed by the file contents
1134 # TODO : we should copy files in blocks
1135 my $data = `cat $file_local`;
1136 $log->debug("File size : " . length($data));
1137 print length($data) . "\n";
1138 print $data;
1139 }
1141 chdir "/";
1142 }
1144 }
1146 print "ok\n";
1147 }
1149 sub req_ci
1150 {
1151 my ( $cmd, $data ) = @_;
1153 argsplit("ci");
1155 #$log->debug("State : " . Dumper($state));
1157 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1159 if ( $state->{method} eq 'pserver')
1160 {
1161 print "error 1 pserver access cannot commit\n";
1162 exit;
1163 }
1165 if ( -e $state->{CVSROOT} . "/index" )
1166 {
1167 $log->warn("file 'index' already exists in the git repository");
1168 print "error 1 Index already exists in git repo\n";
1169 exit;
1170 }
1172 # Grab a handle to the SQLite db and do any necessary updates
1173 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1174 $updater->update();
1176 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1177 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1178 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1180 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1181 $ENV{GIT_INDEX_FILE} = $file_index;
1183 # Remember where the head was at the beginning.
1184 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1185 chomp $parenthash;
1186 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1187 print "error 1 pserver cannot find the current HEAD of module";
1188 exit;
1189 }
1191 chdir $tmpdir;
1193 # populate the temporary index based
1194 system("git-read-tree", $parenthash);
1195 unless ($? == 0)
1196 {
1197 die "Error running git-read-tree $state->{module} $file_index $!";
1198 }
1199 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1201 my @committedfiles = ();
1202 my %oldmeta;
1204 # foreach file specified on the command line ...
1205 foreach my $filename ( @{$state->{args}} )
1206 {
1207 my $committedfile = $filename;
1208 $filename = filecleanup($filename);
1210 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1212 my $meta = $updater->getmeta($filename);
1213 $oldmeta{$filename} = $meta;
1215 my $wrev = revparse($filename);
1217 my ( $filepart, $dirpart ) = filenamesplit($filename);
1219 # do a checkout of the file if it part of this tree
1220 if ($wrev) {
1221 system('git-checkout-index', '-f', '-u', $filename);
1222 unless ($? == 0) {
1223 die "Error running git-checkout-index -f -u $filename : $!";
1224 }
1225 }
1227 my $addflag = 0;
1228 my $rmflag = 0;
1229 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1230 $addflag = 1 unless ( -e $filename );
1232 # Do up to date checking
1233 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1234 {
1235 # fail everything if an up to date check fails
1236 print "error 1 Up to date check failed for $filename\n";
1237 chdir "/";
1238 exit;
1239 }
1241 push @committedfiles, $committedfile;
1242 $log->info("Committing $filename");
1244 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1246 unless ( $rmflag )
1247 {
1248 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1249 rename $state->{entries}{$filename}{modified_filename},$filename;
1251 # Calculate modes to remove
1252 my $invmode = "";
1253 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1255 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1256 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1257 }
1259 if ( $rmflag )
1260 {
1261 $log->info("Removing file '$filename'");
1262 unlink($filename);
1263 system("git-update-index", "--remove", $filename);
1264 }
1265 elsif ( $addflag )
1266 {
1267 $log->info("Adding file '$filename'");
1268 system("git-update-index", "--add", $filename);
1269 } else {
1270 $log->info("Updating file '$filename'");
1271 system("git-update-index", $filename);
1272 }
1273 }
1275 unless ( scalar(@committedfiles) > 0 )
1276 {
1277 print "E No files to commit\n";
1278 print "ok\n";
1279 chdir "/";
1280 return;
1281 }
1283 my $treehash = `git-write-tree`;
1284 chomp $treehash;
1286 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1288 # write our commit message out if we have one ...
1289 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1290 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1291 print $msg_fh "\n\nvia git-CVS emulator\n";
1292 close $msg_fh;
1294 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1295 chomp($commithash);
1296 $log->info("Commit hash : $commithash");
1298 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1299 {
1300 $log->warn("Commit failed (Invalid commit hash)");
1301 print "error 1 Commit failed (unknown reason)\n";
1302 chdir "/";
1303 exit;
1304 }
1306 # Check that this is allowed, just as we would with a receive-pack
1307 my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1308 $parenthash, $commithash );
1309 if( -x $cmd[0] ) {
1310 unless( system( @cmd ) == 0 )
1311 {
1312 $log->warn("Commit failed (update hook declined to update ref)");
1313 print "error 1 Commit failed (update hook declined)\n";
1314 chdir "/";
1315 exit;
1316 }
1317 }
1319 if (system(qw(git update-ref -m), "cvsserver ci",
1320 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1321 $log->warn("update-ref for $state->{module} failed.");
1322 print "error 1 Cannot commit -- update first\n";
1323 exit;
1324 }
1326 $updater->update();
1328 # foreach file specified on the command line ...
1329 foreach my $filename ( @committedfiles )
1330 {
1331 $filename = filecleanup($filename);
1333 my $meta = $updater->getmeta($filename);
1334 unless (defined $meta->{revision}) {
1335 $meta->{revision} = 1;
1336 }
1338 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1340 $log->debug("Checked-in $dirpart : $filename");
1342 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1343 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1344 {
1345 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1346 print "Remove-entry $dirpart\n";
1347 print "$filename\n";
1348 } else {
1349 if ($meta->{revision} == 1) {
1350 print "M initial revision: 1.1\n";
1351 } else {
1352 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1353 }
1354 print "Checked-in $dirpart\n";
1355 print "$filename\n";
1356 my $kopts = kopts_from_path($filepart);
1357 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1358 }
1359 }
1361 chdir "/";
1362 print "ok\n";
1363 }
1365 sub req_status
1366 {
1367 my ( $cmd, $data ) = @_;
1369 argsplit("status");
1371 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1372 #$log->debug("status state : " . Dumper($state));
1374 # Grab a handle to the SQLite db and do any necessary updates
1375 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1376 $updater->update();
1378 # if no files were specified, we need to work out what files we should be providing status on ...
1379 argsfromdir($updater);
1381 # foreach file specified on the command line ...
1382 foreach my $filename ( @{$state->{args}} )
1383 {
1384 $filename = filecleanup($filename);
1386 my $meta = $updater->getmeta($filename);
1387 my $oldmeta = $meta;
1389 my $wrev = revparse($filename);
1391 # If the working copy is an old revision, lets get that version too for comparison.
1392 if ( defined($wrev) and $wrev != $meta->{revision} )
1393 {
1394 $oldmeta = $updater->getmeta($filename, $wrev);
1395 }
1397 # TODO : All possible statuses aren't yet implemented
1398 my $status;
1399 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1400 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1401 and
1402 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1403 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1404 );
1406 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1407 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1408 and
1409 ( $state->{entries}{$filename}{unchanged}
1410 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1411 );
1413 # Need checkout if it exists in the repo but doesn't have a working copy
1414 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1416 # Locally modified if working copy and repo copy have the same revision but there are local changes
1417 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1419 # Needs Merge if working copy revision is less than repo copy and there are local changes
1420 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1422 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1423 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1424 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1425 $status ||= "File had conflicts on merge" if ( 0 );
1427 $status ||= "Unknown";
1429 print "M ===================================================================\n";
1430 print "M File: $filename\tStatus: $status\n";
1431 if ( defined($state->{entries}{$filename}{revision}) )
1432 {
1433 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1434 } else {
1435 print "M Working revision:\tNo entry for $filename\n";
1436 }
1437 if ( defined($meta->{revision}) )
1438 {
1439 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1440 print "M Sticky Tag:\t\t(none)\n";
1441 print "M Sticky Date:\t\t(none)\n";
1442 print "M Sticky Options:\t\t(none)\n";
1443 } else {
1444 print "M Repository revision:\tNo revision control file\n";
1445 }
1446 print "M\n";
1447 }
1449 print "ok\n";
1450 }
1452 sub req_diff
1453 {
1454 my ( $cmd, $data ) = @_;
1456 argsplit("diff");
1458 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1459 #$log->debug("status state : " . Dumper($state));
1461 my ($revision1, $revision2);
1462 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1463 {
1464 $revision1 = $state->{opt}{r}[0];
1465 $revision2 = $state->{opt}{r}[1];
1466 } else {
1467 $revision1 = $state->{opt}{r};
1468 }
1470 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1471 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1473 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1475 # Grab a handle to the SQLite db and do any necessary updates
1476 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1477 $updater->update();
1479 # if no files were specified, we need to work out what files we should be providing status on ...
1480 argsfromdir($updater);
1482 # foreach file specified on the command line ...
1483 foreach my $filename ( @{$state->{args}} )
1484 {
1485 $filename = filecleanup($filename);
1487 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1489 my $wrev = revparse($filename);
1491 # We need _something_ to diff against
1492 next unless ( defined ( $wrev ) );
1494 # if we have a -r switch, use it
1495 if ( defined ( $revision1 ) )
1496 {
1497 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1498 $meta1 = $updater->getmeta($filename, $revision1);
1499 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1500 {
1501 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1502 next;
1503 }
1504 transmitfile($meta1->{filehash}, $file1);
1505 }
1506 # otherwise we just use the working copy revision
1507 else
1508 {
1509 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1510 $meta1 = $updater->getmeta($filename, $wrev);
1511 transmitfile($meta1->{filehash}, $file1);
1512 }
1514 # if we have a second -r switch, use it too
1515 if ( defined ( $revision2 ) )
1516 {
1517 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1518 $meta2 = $updater->getmeta($filename, $revision2);
1520 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1521 {
1522 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1523 next;
1524 }
1526 transmitfile($meta2->{filehash}, $file2);
1527 }
1528 # otherwise we just use the working copy
1529 else
1530 {
1531 $file2 = $state->{entries}{$filename}{modified_filename};
1532 }
1534 # if we have been given -r, and we don't have a $file2 yet, lets get one
1535 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1536 {
1537 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1538 $meta2 = $updater->getmeta($filename, $wrev);
1539 transmitfile($meta2->{filehash}, $file2);
1540 }
1542 # We need to have retrieved something useful
1543 next unless ( defined ( $meta1 ) );
1545 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1546 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1547 and
1548 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1549 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1550 );
1552 # Apparently we only show diffs for locally modified files
1553 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1555 print "M Index: $filename\n";
1556 print "M ===================================================================\n";
1557 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1558 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1559 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1560 print "M diff ";
1561 foreach my $opt ( keys %{$state->{opt}} )
1562 {
1563 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1564 {
1565 foreach my $value ( @{$state->{opt}{$opt}} )
1566 {
1567 print "-$opt $value ";
1568 }
1569 } else {
1570 print "-$opt ";
1571 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1572 }
1573 }
1574 print "$filename\n";
1576 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1578 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1580 if ( exists $state->{opt}{u} )
1581 {
1582 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1583 } else {
1584 system("diff $file1 $file2 > $filediff");
1585 }
1587 while ( <$fh> )
1588 {
1589 print "M $_";
1590 }
1591 close $fh;
1592 }
1594 print "ok\n";
1595 }
1597 sub req_log
1598 {
1599 my ( $cmd, $data ) = @_;
1601 argsplit("log");
1603 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1604 #$log->debug("log state : " . Dumper($state));
1606 my ( $minrev, $maxrev );
1607 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1608 {
1609 my $control = $2;
1610 $minrev = $1;
1611 $maxrev = $3;
1612 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1613 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1614 $minrev++ if ( defined($minrev) and $control eq "::" );
1615 }
1617 # Grab a handle to the SQLite db and do any necessary updates
1618 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1619 $updater->update();
1621 # if no files were specified, we need to work out what files we should be providing status on ...
1622 argsfromdir($updater);
1624 # foreach file specified on the command line ...
1625 foreach my $filename ( @{$state->{args}} )
1626 {
1627 $filename = filecleanup($filename);
1629 my $headmeta = $updater->getmeta($filename);
1631 my $revisions = $updater->getlog($filename);
1632 my $totalrevisions = scalar(@$revisions);
1634 if ( defined ( $minrev ) )
1635 {
1636 $log->debug("Removing revisions less than $minrev");
1637 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1638 {
1639 pop @$revisions;
1640 }
1641 }
1642 if ( defined ( $maxrev ) )
1643 {
1644 $log->debug("Removing revisions greater than $maxrev");
1645 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1646 {
1647 shift @$revisions;
1648 }
1649 }
1651 next unless ( scalar(@$revisions) );
1653 print "M \n";
1654 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1655 print "M Working file: $filename\n";
1656 print "M head: 1.$headmeta->{revision}\n";
1657 print "M branch:\n";
1658 print "M locks: strict\n";
1659 print "M access list:\n";
1660 print "M symbolic names:\n";
1661 print "M keyword substitution: kv\n";
1662 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1663 print "M description:\n";
1665 foreach my $revision ( @$revisions )
1666 {
1667 print "M ----------------------------\n";
1668 print "M revision 1.$revision->{revision}\n";
1669 # reformat the date for log output
1670 $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}) );
1671 $revision->{author} =~ s/\s+.*//;
1672 $revision->{author} =~ s/^(.{8}).*/$1/;
1673 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1674 my $commitmessage = $updater->commitmessage($revision->{commithash});
1675 $commitmessage =~ s/^/M /mg;
1676 print $commitmessage . "\n";
1677 }
1678 print "M =============================================================================\n";
1679 }
1681 print "ok\n";
1682 }
1684 sub req_annotate
1685 {
1686 my ( $cmd, $data ) = @_;
1688 argsplit("annotate");
1690 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1691 #$log->debug("status state : " . Dumper($state));
1693 # Grab a handle to the SQLite db and do any necessary updates
1694 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1695 $updater->update();
1697 # if no files were specified, we need to work out what files we should be providing annotate on ...
1698 argsfromdir($updater);
1700 # we'll need a temporary checkout dir
1701 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1702 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1703 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1705 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1706 $ENV{GIT_INDEX_FILE} = $file_index;
1708 chdir $tmpdir;
1710 # foreach file specified on the command line ...
1711 foreach my $filename ( @{$state->{args}} )
1712 {
1713 $filename = filecleanup($filename);
1715 my $meta = $updater->getmeta($filename);
1717 next unless ( $meta->{revision} );
1719 # get all the commits that this file was in
1720 # in dense format -- aka skip dead revisions
1721 my $revisions = $updater->gethistorydense($filename);
1722 my $lastseenin = $revisions->[0][2];
1724 # populate the temporary index based on the latest commit were we saw
1725 # the file -- but do it cheaply without checking out any files
1726 # TODO: if we got a revision from the client, use that instead
1727 # to look up the commithash in sqlite (still good to default to
1728 # the current head as we do now)
1729 system("git-read-tree", $lastseenin);
1730 unless ($? == 0)
1731 {
1732 die "Error running git-read-tree $lastseenin $file_index $!";
1733 }
1734 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1736 # do a checkout of the file
1737 system('git-checkout-index', '-f', '-u', $filename);
1738 unless ($? == 0) {
1739 die "Error running git-checkout-index -f -u $filename : $!";
1740 }
1742 $log->info("Annotate $filename");
1744 # Prepare a file with the commits from the linearized
1745 # history that annotate should know about. This prevents
1746 # git-jsannotate telling us about commits we are hiding
1747 # from the client.
1749 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1750 for (my $i=0; $i < @$revisions; $i++)
1751 {
1752 print ANNOTATEHINTS $revisions->[$i][2];
1753 if ($i+1 < @$revisions) { # have we got a parent?
1754 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1755 }
1756 print ANNOTATEHINTS "\n";
1757 }
1759 print ANNOTATEHINTS "\n";
1760 close ANNOTATEHINTS;
1762 my $annotatecmd = 'git-annotate';
1763 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1764 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1765 my $metadata = {};
1766 print "E Annotations for $filename\n";
1767 print "E ***************\n";
1768 while ( <ANNOTATE> )
1769 {
1770 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1771 {
1772 my $commithash = $1;
1773 my $data = $2;
1774 unless ( defined ( $metadata->{$commithash} ) )
1775 {
1776 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1777 $metadata->{$commithash}{author} =~ s/\s+.*//;
1778 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1779 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1780 }
1781 printf("M 1.%-5d (%-8s %10s): %s\n",
1782 $metadata->{$commithash}{revision},
1783 $metadata->{$commithash}{author},
1784 $metadata->{$commithash}{modified},
1785 $data
1786 );
1787 } else {
1788 $log->warn("Error in annotate output! LINE: $_");
1789 print "E Annotate error \n";
1790 next;
1791 }
1792 }
1793 close ANNOTATE;
1794 }
1796 # done; get out of the tempdir
1797 chdir "/";
1799 print "ok\n";
1801 }
1803 # This method takes the state->{arguments} array and produces two new arrays.
1804 # The first is $state->{args} which is everything before the '--' argument, and
1805 # the second is $state->{files} which is everything after it.
1806 sub argsplit
1807 {
1808 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1810 my $type = shift;
1812 $state->{args} = [];
1813 $state->{files} = [];
1814 $state->{opt} = {};
1816 if ( defined($type) )
1817 {
1818 my $opt = {};
1819 $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" );
1820 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1821 $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" );
1822 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1823 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1824 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1825 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1826 $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" );
1829 while ( scalar ( @{$state->{arguments}} ) > 0 )
1830 {
1831 my $arg = shift @{$state->{arguments}};
1833 next if ( $arg eq "--" );
1834 next unless ( $arg =~ /\S/ );
1836 # if the argument looks like a switch
1837 if ( $arg =~ /^-(\w)(.*)/ )
1838 {
1839 # if it's a switch that takes an argument
1840 if ( $opt->{$1} )
1841 {
1842 # If this switch has already been provided
1843 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1844 {
1845 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1846 if ( length($2) > 0 )
1847 {
1848 push @{$state->{opt}{$1}},$2;
1849 } else {
1850 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1851 }
1852 } else {
1853 # if there's extra data in the arg, use that as the argument for the switch
1854 if ( length($2) > 0 )
1855 {
1856 $state->{opt}{$1} = $2;
1857 } else {
1858 $state->{opt}{$1} = shift @{$state->{arguments}};
1859 }
1860 }
1861 } else {
1862 $state->{opt}{$1} = undef;
1863 }
1864 }
1865 else
1866 {
1867 push @{$state->{args}}, $arg;
1868 }
1869 }
1870 }
1871 else
1872 {
1873 my $mode = 0;
1875 foreach my $value ( @{$state->{arguments}} )
1876 {
1877 if ( $value eq "--" )
1878 {
1879 $mode++;
1880 next;
1881 }
1882 push @{$state->{args}}, $value if ( $mode == 0 );
1883 push @{$state->{files}}, $value if ( $mode == 1 );
1884 }
1885 }
1886 }
1888 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1889 sub argsfromdir
1890 {
1891 my $updater = shift;
1893 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1895 return if ( scalar ( @{$state->{args}} ) > 1 );
1897 my @gethead = @{$updater->gethead};
1899 # push added files
1900 foreach my $file (keys %{$state->{entries}}) {
1901 if ( exists $state->{entries}{$file}{revision} &&
1902 $state->{entries}{$file}{revision} == 0 )
1903 {
1904 push @gethead, { name => $file, filehash => 'added' };
1905 }
1906 }
1908 if ( scalar(@{$state->{args}}) == 1 )
1909 {
1910 my $arg = $state->{args}[0];
1911 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1913 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1915 foreach my $file ( @gethead )
1916 {
1917 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1918 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1919 push @{$state->{args}}, $file->{name};
1920 }
1922 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1923 } else {
1924 $log->info("Only one arg specified, populating file list automatically");
1926 $state->{args} = [];
1928 foreach my $file ( @gethead )
1929 {
1930 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1931 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1932 push @{$state->{args}}, $file->{name};
1933 }
1934 }
1935 }
1937 # This method cleans up the $state variable after a command that uses arguments has run
1938 sub statecleanup
1939 {
1940 $state->{files} = [];
1941 $state->{args} = [];
1942 $state->{arguments} = [];
1943 $state->{entries} = {};
1944 }
1946 sub revparse
1947 {
1948 my $filename = shift;
1950 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1952 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1953 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1955 return undef;
1956 }
1958 # This method takes a file hash and does a CVS "file transfer" which transmits the
1959 # size of the file, and then the file contents.
1960 # If a second argument $targetfile is given, the file is instead written out to
1961 # a file by the name of $targetfile
1962 sub transmitfile
1963 {
1964 my $filehash = shift;
1965 my $targetfile = shift;
1967 if ( defined ( $filehash ) and $filehash eq "deleted" )
1968 {
1969 $log->warn("filehash is 'deleted'");
1970 return;
1971 }
1973 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1975 my $type = `git-cat-file -t $filehash`;
1976 chomp $type;
1978 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1980 my $size = `git-cat-file -s $filehash`;
1981 chomp $size;
1983 $log->debug("transmitfile($filehash) size=$size, type=$type");
1985 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1986 {
1987 if ( defined ( $targetfile ) )
1988 {
1989 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1990 print NEWFILE $_ while ( <$fh> );
1991 close NEWFILE;
1992 } else {
1993 print "$size\n";
1994 print while ( <$fh> );
1995 }
1996 close $fh or die ("Couldn't close filehandle for transmitfile()");
1997 } else {
1998 die("Couldn't execute git-cat-file");
1999 }
2000 }
2002 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2003 # refers to the directory portion and the file portion of the filename
2004 # respectively
2005 sub filenamesplit
2006 {
2007 my $filename = shift;
2008 my $fixforlocaldir = shift;
2010 my ( $filepart, $dirpart ) = ( $filename, "." );
2011 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2012 $dirpart .= "/";
2014 if ( $fixforlocaldir )
2015 {
2016 $dirpart =~ s/^$state->{prependdir}//;
2017 }
2019 return ( $filepart, $dirpart );
2020 }
2022 sub filecleanup
2023 {
2024 my $filename = shift;
2026 return undef unless(defined($filename));
2027 if ( $filename =~ /^\// )
2028 {
2029 print "E absolute filenames '$filename' not supported by server\n";
2030 return undef;
2031 }
2033 $filename =~ s/^\.\///g;
2034 $filename = $state->{prependdir} . $filename;
2035 return $filename;
2036 }
2038 # Given a path, this function returns a string containing the kopts
2039 # that should go into that path's Entries line. For example, a binary
2040 # file should get -kb.
2041 sub kopts_from_path
2042 {
2043 my ($path) = @_;
2045 # Once it exists, the git attributes system should be used to look up
2046 # what attributes apply to this path.
2048 # Until then, take the setting from the config file
2049 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
2050 {
2051 # Return "" to give no special treatment to any path
2052 return "";
2053 } else {
2054 # Alternatively, to have all files treated as if they are binary (which
2055 # is more like git itself), always return the "-kb" option
2056 return "-kb";
2057 }
2058 }
2060 package GITCVS::log;
2062 ####
2063 #### Copyright The Open University UK - 2006.
2064 ####
2065 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2066 #### Martin Langhoff <martin@catalyst.net.nz>
2067 ####
2068 ####
2070 use strict;
2071 use warnings;
2073 =head1 NAME
2075 GITCVS::log
2077 =head1 DESCRIPTION
2079 This module provides very crude logging with a similar interface to
2080 Log::Log4perl
2082 =head1 METHODS
2084 =cut
2086 =head2 new
2088 Creates a new log object, optionally you can specify a filename here to
2089 indicate the file to log to. If no log file is specified, you can specify one
2090 later with method setfile, or indicate you no longer want logging with method
2091 nofile.
2093 Until one of these methods is called, all log calls will buffer messages ready
2094 to write out.
2096 =cut
2097 sub new
2098 {
2099 my $class = shift;
2100 my $filename = shift;
2102 my $self = {};
2104 bless $self, $class;
2106 if ( defined ( $filename ) )
2107 {
2108 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2109 }
2111 return $self;
2112 }
2114 =head2 setfile
2116 This methods takes a filename, and attempts to open that file as the log file.
2117 If successful, all buffered data is written out to the file, and any further
2118 logging is written directly to the file.
2120 =cut
2121 sub setfile
2122 {
2123 my $self = shift;
2124 my $filename = shift;
2126 if ( defined ( $filename ) )
2127 {
2128 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2129 }
2131 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2133 while ( my $line = shift @{$self->{buffer}} )
2134 {
2135 print {$self->{fh}} $line;
2136 }
2137 }
2139 =head2 nofile
2141 This method indicates no logging is going to be used. It flushes any entries in
2142 the internal buffer, and sets a flag to ensure no further data is put there.
2144 =cut
2145 sub nofile
2146 {
2147 my $self = shift;
2149 $self->{nolog} = 1;
2151 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2153 $self->{buffer} = [];
2154 }
2156 =head2 _logopen
2158 Internal method. Returns true if the log file is open, false otherwise.
2160 =cut
2161 sub _logopen
2162 {
2163 my $self = shift;
2165 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2166 return 0;
2167 }
2169 =head2 debug info warn fatal
2171 These four methods are wrappers to _log. They provide the actual interface for
2172 logging data.
2174 =cut
2175 sub debug { my $self = shift; $self->_log("debug", @_); }
2176 sub info { my $self = shift; $self->_log("info" , @_); }
2177 sub warn { my $self = shift; $self->_log("warn" , @_); }
2178 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2180 =head2 _log
2182 This is an internal method called by the logging functions. It generates a
2183 timestamp and pushes the logged line either to file, or internal buffer.
2185 =cut
2186 sub _log
2187 {
2188 my $self = shift;
2189 my $level = shift;
2191 return if ( $self->{nolog} );
2193 my @time = localtime;
2194 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2195 $time[5] + 1900,
2196 $time[4] + 1,
2197 $time[3],
2198 $time[2],
2199 $time[1],
2200 $time[0],
2201 uc $level,
2202 );
2204 if ( $self->_logopen )
2205 {
2206 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2207 } else {
2208 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2209 }
2210 }
2212 =head2 DESTROY
2214 This method simply closes the file handle if one is open
2216 =cut
2217 sub DESTROY
2218 {
2219 my $self = shift;
2221 if ( $self->_logopen )
2222 {
2223 close $self->{fh};
2224 }
2225 }
2227 package GITCVS::updater;
2229 ####
2230 #### Copyright The Open University UK - 2006.
2231 ####
2232 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2233 #### Martin Langhoff <martin@catalyst.net.nz>
2234 ####
2235 ####
2237 use strict;
2238 use warnings;
2239 use DBI;
2241 =head1 METHODS
2243 =cut
2245 =head2 new
2247 =cut
2248 sub new
2249 {
2250 my $class = shift;
2251 my $config = shift;
2252 my $module = shift;
2253 my $log = shift;
2255 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2256 die "Need to specify a module" unless ( defined($module) );
2258 $class = ref($class) || $class;
2260 my $self = {};
2262 bless $self, $class;
2264 $self->{module} = $module;
2265 $self->{git_path} = $config . "/";
2267 $self->{log} = $log;
2269 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2271 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2272 $cfg->{gitcvs}{dbdriver} || "SQLite";
2273 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2274 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2275 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2276 $cfg->{gitcvs}{dbuser} || "";
2277 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2278 $cfg->{gitcvs}{dbpass} || "";
2279 my %mapping = ( m => $module,
2280 a => $state->{method},
2281 u => getlogin || getpwuid($<) || $<,
2282 G => $self->{git_path},
2283 g => mangle_dirname($self->{git_path}),
2284 );
2285 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2286 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2288 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2289 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2290 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2291 $self->{dbuser},
2292 $self->{dbpass});
2293 die "Error connecting to database\n" unless defined $self->{dbh};
2295 $self->{tables} = {};
2296 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2297 {
2298 $self->{tables}{$table} = 1;
2299 }
2301 # Construct the revision table if required
2302 unless ( $self->{tables}{revision} )
2303 {
2304 $self->{dbh}->do("
2305 CREATE TABLE revision (
2306 name TEXT NOT NULL,
2307 revision INTEGER NOT NULL,
2308 filehash TEXT NOT NULL,
2309 commithash TEXT NOT NULL,
2310 author TEXT NOT NULL,
2311 modified TEXT NOT NULL,
2312 mode TEXT NOT NULL
2313 )
2314 ");
2315 $self->{dbh}->do("
2316 CREATE INDEX revision_ix1
2317 ON revision (name,revision)
2318 ");
2319 $self->{dbh}->do("
2320 CREATE INDEX revision_ix2
2321 ON revision (name,commithash)
2322 ");
2323 }
2325 # Construct the head table if required
2326 unless ( $self->{tables}{head} )
2327 {
2328 $self->{dbh}->do("
2329 CREATE TABLE head (
2330 name TEXT NOT NULL,
2331 revision INTEGER NOT NULL,
2332 filehash TEXT NOT NULL,
2333 commithash TEXT NOT NULL,
2334 author TEXT NOT NULL,
2335 modified TEXT NOT NULL,
2336 mode TEXT NOT NULL
2337 )
2338 ");
2339 $self->{dbh}->do("
2340 CREATE INDEX head_ix1
2341 ON head (name)
2342 ");
2343 }
2345 # Construct the properties table if required
2346 unless ( $self->{tables}{properties} )
2347 {
2348 $self->{dbh}->do("
2349 CREATE TABLE properties (
2350 key TEXT NOT NULL PRIMARY KEY,
2351 value TEXT
2352 )
2353 ");
2354 }
2356 # Construct the commitmsgs table if required
2357 unless ( $self->{tables}{commitmsgs} )
2358 {
2359 $self->{dbh}->do("
2360 CREATE TABLE commitmsgs (
2361 key TEXT NOT NULL PRIMARY KEY,
2362 value TEXT
2363 )
2364 ");
2365 }
2367 return $self;
2368 }
2370 =head2 update
2372 =cut
2373 sub update
2374 {
2375 my $self = shift;
2377 # first lets get the commit list
2378 $ENV{GIT_DIR} = $self->{git_path};
2380 my $commitsha1 = `git rev-parse $self->{module}`;
2381 chomp $commitsha1;
2383 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2384 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2385 {
2386 die("Invalid module '$self->{module}'");
2387 }
2390 my $git_log;
2391 my $lastcommit = $self->_get_prop("last_commit");
2393 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2394 return 1;
2395 }
2397 # Start exclusive lock here...
2398 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2400 # TODO: log processing is memory bound
2401 # if we can parse into a 2nd file that is in reverse order
2402 # we can probably do something really efficient
2403 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2405 if (defined $lastcommit) {
2406 push @git_log_params, "$lastcommit..$self->{module}";
2407 } else {
2408 push @git_log_params, $self->{module};
2409 }
2410 # git-rev-list is the backend / plumbing version of git-log
2411 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2413 my @commits;
2415 my %commit = ();
2417 while ( <GITLOG> )
2418 {
2419 chomp;
2420 if (m/^commit\s+(.*)$/) {
2421 # on ^commit lines put the just seen commit in the stack
2422 # and prime things for the next one
2423 if (keys %commit) {
2424 my %copy = %commit;
2425 unshift @commits, \%copy;
2426 %commit = ();
2427 }
2428 my @parents = split(m/\s+/, $1);
2429 $commit{hash} = shift @parents;
2430 $commit{parents} = \@parents;
2431 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2432 # on rfc822-like lines seen before we see any message,
2433 # lowercase the entry and put it in the hash as key-value
2434 $commit{lc($1)} = $2;
2435 } else {
2436 # message lines - skip initial empty line
2437 # and trim whitespace
2438 if (!exists($commit{message}) && m/^\s*$/) {
2439 # define it to mark the end of headers
2440 $commit{message} = '';
2441 next;
2442 }
2443 s/^\s+//; s/\s+$//; # trim ws
2444 $commit{message} .= $_ . "\n";
2445 }
2446 }
2447 close GITLOG;
2449 unshift @commits, \%commit if ( keys %commit );
2451 # Now all the commits are in the @commits bucket
2452 # ordered by time DESC. for each commit that needs processing,
2453 # determine whether it's following the last head we've seen or if
2454 # it's on its own branch, grab a file list, and add whatever's changed
2455 # NOTE: $lastcommit refers to the last commit from previous run
2456 # $lastpicked is the last commit we picked in this run
2457 my $lastpicked;
2458 my $head = {};
2459 if (defined $lastcommit) {
2460 $lastpicked = $lastcommit;
2461 }
2463 my $committotal = scalar(@commits);
2464 my $commitcount = 0;
2466 # Load the head table into $head (for cached lookups during the update process)
2467 foreach my $file ( @{$self->gethead()} )
2468 {
2469 $head->{$file->{name}} = $file;
2470 }
2472 foreach my $commit ( @commits )
2473 {
2474 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2475 if (defined $lastpicked)
2476 {
2477 if (!in_array($lastpicked, @{$commit->{parents}}))
2478 {
2479 # skip, we'll see this delta
2480 # as part of a merge later
2481 # warn "skipping off-track $commit->{hash}\n";
2482 next;
2483 } elsif (@{$commit->{parents}} > 1) {
2484 # it is a merge commit, for each parent that is
2485 # not $lastpicked, see if we can get a log
2486 # from the merge-base to that parent to put it
2487 # in the message as a merge summary.
2488 my @parents = @{$commit->{parents}};
2489 foreach my $parent (@parents) {
2490 # git-merge-base can potentially (but rarely) throw
2491 # several candidate merge bases. let's assume
2492 # that the first one is the best one.
2493 if ($parent eq $lastpicked) {
2494 next;
2495 }
2496 open my $p, 'git-merge-base '. $lastpicked . ' '
2497 . $parent . '|';
2498 my @output = (<$p>);
2499 close $p;
2500 my $base = join('', @output);
2501 chomp $base;
2502 if ($base) {
2503 my @merged;
2504 # print "want to log between $base $parent \n";
2505 open(GITLOG, '-|', 'git-log', "$base..$parent")
2506 or die "Cannot call git-log: $!";
2507 my $mergedhash;
2508 while (<GITLOG>) {
2509 chomp;
2510 if (!defined $mergedhash) {
2511 if (m/^commit\s+(.+)$/) {
2512 $mergedhash = $1;
2513 } else {
2514 next;
2515 }
2516 } else {
2517 # grab the first line that looks non-rfc822
2518 # aka has content after leading space
2519 if (m/^\s+(\S.*)$/) {
2520 my $title = $1;
2521 $title = substr($title,0,100); # truncate
2522 unshift @merged, "$mergedhash $title";
2523 undef $mergedhash;
2524 }
2525 }
2526 }
2527 close GITLOG;
2528 if (@merged) {
2529 $commit->{mergemsg} = $commit->{message};
2530 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2531 foreach my $summary (@merged) {
2532 $commit->{mergemsg} .= "\t$summary\n";
2533 }
2534 $commit->{mergemsg} .= "\n\n";
2535 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2536 }
2537 }
2538 }
2539 }
2540 }
2542 # convert the date to CVS-happy format
2543 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2545 if ( defined ( $lastpicked ) )
2546 {
2547 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2548 local ($/) = "\0";
2549 while ( <FILELIST> )
2550 {
2551 chomp;
2552 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2553 {
2554 die("Couldn't process git-diff-tree line : $_");
2555 }
2556 my ($mode, $hash, $change) = ($1, $2, $3);
2557 my $name = <FILELIST>;
2558 chomp($name);
2560 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2562 my $git_perms = "";
2563 $git_perms .= "r" if ( $mode & 4 );
2564 $git_perms .= "w" if ( $mode & 2 );
2565 $git_perms .= "x" if ( $mode & 1 );
2566 $git_perms = "rw" if ( $git_perms eq "" );
2568 if ( $change eq "D" )
2569 {
2570 #$log->debug("DELETE $name");
2571 $head->{$name} = {
2572 name => $name,
2573 revision => $head->{$name}{revision} + 1,
2574 filehash => "deleted",
2575 commithash => $commit->{hash},
2576 modified => $commit->{date},
2577 author => $commit->{author},
2578 mode => $git_perms,
2579 };
2580 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2581 }
2582 elsif ( $change eq "M" )
2583 {
2584 #$log->debug("MODIFIED $name");
2585 $head->{$name} = {
2586 name => $name,
2587 revision => $head->{$name}{revision} + 1,
2588 filehash => $hash,
2589 commithash => $commit->{hash},
2590 modified => $commit->{date},
2591 author => $commit->{author},
2592 mode => $git_perms,
2593 };
2594 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2595 }
2596 elsif ( $change eq "A" )
2597 {
2598 #$log->debug("ADDED $name");
2599 $head->{$name} = {
2600 name => $name,
2601 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
2602 filehash => $hash,
2603 commithash => $commit->{hash},
2604 modified => $commit->{date},
2605 author => $commit->{author},
2606 mode => $git_perms,
2607 };
2608 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2609 }
2610 else
2611 {
2612 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2613 die;
2614 }
2615 }
2616 close FILELIST;
2617 } else {
2618 # this is used to detect files removed from the repo
2619 my $seen_files = {};
2621 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2622 local $/ = "\0";
2623 while ( <FILELIST> )
2624 {
2625 chomp;
2626 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2627 {
2628 die("Couldn't process git-ls-tree line : $_");
2629 }
2631 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2633 $seen_files->{$git_filename} = 1;
2635 my ( $oldhash, $oldrevision, $oldmode ) = (
2636 $head->{$git_filename}{filehash},
2637 $head->{$git_filename}{revision},
2638 $head->{$git_filename}{mode}
2639 );
2641 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2642 {
2643 $git_perms = "";
2644 $git_perms .= "r" if ( $1 & 4 );
2645 $git_perms .= "w" if ( $1 & 2 );
2646 $git_perms .= "x" if ( $1 & 1 );
2647 } else {
2648 $git_perms = "rw";
2649 }
2651 # unless the file exists with the same hash, we need to update it ...
2652 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2653 {
2654 my $newrevision = ( $oldrevision or 0 ) + 1;
2656 $head->{$git_filename} = {
2657 name => $git_filename,
2658 revision => $newrevision,
2659 filehash => $git_hash,
2660 commithash => $commit->{hash},
2661 modified => $commit->{date},
2662 author => $commit->{author},
2663 mode => $git_perms,
2664 };
2667 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2668 }
2669 }
2670 close FILELIST;
2672 # Detect deleted files
2673 foreach my $file ( keys %$head )
2674 {
2675 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2676 {
2677 $head->{$file}{revision}++;
2678 $head->{$file}{filehash} = "deleted";
2679 $head->{$file}{commithash} = $commit->{hash};
2680 $head->{$file}{modified} = $commit->{date};
2681 $head->{$file}{author} = $commit->{author};
2683 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2684 }
2685 }
2686 # END : "Detect deleted files"
2687 }
2690 if (exists $commit->{mergemsg})
2691 {
2692 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2693 }
2695 $lastpicked = $commit->{hash};
2697 $self->_set_prop("last_commit", $commit->{hash});
2698 }
2700 $self->delete_head();
2701 foreach my $file ( keys %$head )
2702 {
2703 $self->insert_head(
2704 $file,
2705 $head->{$file}{revision},
2706 $head->{$file}{filehash},
2707 $head->{$file}{commithash},
2708 $head->{$file}{modified},
2709 $head->{$file}{author},
2710 $head->{$file}{mode},
2711 );
2712 }
2713 # invalidate the gethead cache
2714 $self->{gethead_cache} = undef;
2717 # Ending exclusive lock here
2718 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2719 }
2721 sub insert_rev
2722 {
2723 my $self = shift;
2724 my $name = shift;
2725 my $revision = shift;
2726 my $filehash = shift;
2727 my $commithash = shift;
2728 my $modified = shift;
2729 my $author = shift;
2730 my $mode = shift;
2732 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2733 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2734 }
2736 sub insert_mergelog
2737 {
2738 my $self = shift;
2739 my $key = shift;
2740 my $value = shift;
2742 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2743 $insert_mergelog->execute($key, $value);
2744 }
2746 sub delete_head
2747 {
2748 my $self = shift;
2750 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2751 $delete_head->execute();
2752 }
2754 sub insert_head
2755 {
2756 my $self = shift;
2757 my $name = shift;
2758 my $revision = shift;
2759 my $filehash = shift;
2760 my $commithash = shift;
2761 my $modified = shift;
2762 my $author = shift;
2763 my $mode = shift;
2765 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2766 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2767 }
2769 sub _headrev
2770 {
2771 my $self = shift;
2772 my $filename = shift;
2774 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2775 $db_query->execute($filename);
2776 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2778 return ( $hash, $revision, $mode );
2779 }
2781 sub _get_prop
2782 {
2783 my $self = shift;
2784 my $key = shift;
2786 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2787 $db_query->execute($key);
2788 my ( $value ) = $db_query->fetchrow_array;
2790 return $value;
2791 }
2793 sub _set_prop
2794 {
2795 my $self = shift;
2796 my $key = shift;
2797 my $value = shift;
2799 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2800 $db_query->execute($value, $key);
2802 unless ( $db_query->rows )
2803 {
2804 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2805 $db_query->execute($key, $value);
2806 }
2808 return $value;
2809 }
2811 =head2 gethead
2813 =cut
2815 sub gethead
2816 {
2817 my $self = shift;
2819 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2821 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2822 $db_query->execute();
2824 my $tree = [];
2825 while ( my $file = $db_query->fetchrow_hashref )
2826 {
2827 push @$tree, $file;
2828 }
2830 $self->{gethead_cache} = $tree;
2832 return $tree;
2833 }
2835 =head2 getlog
2837 =cut
2839 sub getlog
2840 {
2841 my $self = shift;
2842 my $filename = shift;
2844 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2845 $db_query->execute($filename);
2847 my $tree = [];
2848 while ( my $file = $db_query->fetchrow_hashref )
2849 {
2850 push @$tree, $file;
2851 }
2853 return $tree;
2854 }
2856 =head2 getmeta
2858 This function takes a filename (with path) argument and returns a hashref of
2859 metadata for that file.
2861 =cut
2863 sub getmeta
2864 {
2865 my $self = shift;
2866 my $filename = shift;
2867 my $revision = shift;
2869 my $db_query;
2870 if ( defined($revision) and $revision =~ /^\d+$/ )
2871 {
2872 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2873 $db_query->execute($filename, $revision);
2874 }
2875 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2876 {
2877 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2878 $db_query->execute($filename, $revision);
2879 } else {
2880 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2881 $db_query->execute($filename);
2882 }
2884 return $db_query->fetchrow_hashref;
2885 }
2887 =head2 commitmessage
2889 this function takes a commithash and returns the commit message for that commit
2891 =cut
2892 sub commitmessage
2893 {
2894 my $self = shift;
2895 my $commithash = shift;
2897 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2899 my $db_query;
2900 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2901 $db_query->execute($commithash);
2903 my ( $message ) = $db_query->fetchrow_array;
2905 if ( defined ( $message ) )
2906 {
2907 $message .= " " if ( $message =~ /\n$/ );
2908 return $message;
2909 }
2911 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2912 shift @lines while ( $lines[0] =~ /\S/ );
2913 $message = join("",@lines);
2914 $message .= " " if ( $message =~ /\n$/ );
2915 return $message;
2916 }
2918 =head2 gethistory
2920 This function takes a filename (with path) argument and returns an arrayofarrays
2921 containing revision,filehash,commithash ordered by revision descending
2923 =cut
2924 sub gethistory
2925 {
2926 my $self = shift;
2927 my $filename = shift;
2929 my $db_query;
2930 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2931 $db_query->execute($filename);
2933 return $db_query->fetchall_arrayref;
2934 }
2936 =head2 gethistorydense
2938 This function takes a filename (with path) argument and returns an arrayofarrays
2939 containing revision,filehash,commithash ordered by revision descending.
2941 This version of gethistory skips deleted entries -- so it is useful for annotate.
2942 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2943 and other git tools that depend on it.
2945 =cut
2946 sub gethistorydense
2947 {
2948 my $self = shift;
2949 my $filename = shift;
2951 my $db_query;
2952 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2953 $db_query->execute($filename);
2955 return $db_query->fetchall_arrayref;
2956 }
2958 =head2 in_array()
2960 from Array::PAT - mimics the in_array() function
2961 found in PHP. Yuck but works for small arrays.
2963 =cut
2964 sub in_array
2965 {
2966 my ($check, @array) = @_;
2967 my $retval = 0;
2968 foreach my $test (@array){
2969 if($check eq $test){
2970 $retval = 1;
2971 }
2972 }
2973 return $retval;
2974 }
2976 =head2 safe_pipe_capture
2978 an alternative to `command` that allows input to be passed as an array
2979 to work around shell problems with weird characters in arguments
2981 =cut
2982 sub safe_pipe_capture {
2984 my @output;
2986 if (my $pid = open my $child, '-|') {
2987 @output = (<$child>);
2988 close $child or die join(' ',@_).": $! $?";
2989 } else {
2990 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2991 }
2992 return wantarray ? @output : join('',@output);
2993 }
2995 =head2 mangle_dirname
2997 create a string from a directory name that is suitable to use as
2998 part of a filename, mainly by converting all chars except \w.- to _
3000 =cut
3001 sub mangle_dirname {
3002 my $dirname = shift;
3003 return unless defined $dirname;
3005 $dirname =~ s/[^\w.-]/_/g;
3007 return $dirname;
3008 }
3010 1;