e5ba57f3946cc5f38cd25bfd0b52ff6ac2209c5b
[git/git.git] / git-cvsserver.perl
1 #!/usr/bin/perl
2
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 ####
17
18 use strict;
19 use warnings;
20 use bytes;
21
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Path qw/rmtree/;
25 use File::Basename;
26 use Getopt::Long qw(:config require_order no_ignore_case);
27
28 my $VERSION = '@@GIT_VERSION@@';
29
30 my $log = GITCVS::log->new();
31 my $cfg;
32
33 my $DATE_LIST = {
34 Jan => "01",
35 Feb => "02",
36 Mar => "03",
37 Apr => "04",
38 May => "05",
39 Jun => "06",
40 Jul => "07",
41 Aug => "08",
42 Sep => "09",
43 Oct => "10",
44 Nov => "11",
45 Dec => "12",
46 };
47
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
49 $| = 1;
50
51 #### Definition and mappings of functions ####
52
53 my $methods = {
54 'Root' => \&req_Root,
55 'Valid-responses' => \&req_Validresponses,
56 'valid-requests' => \&req_validrequests,
57 'Directory' => \&req_Directory,
58 'Entry' => \&req_Entry,
59 'Modified' => \&req_Modified,
60 'Unchanged' => \&req_Unchanged,
61 'Questionable' => \&req_Questionable,
62 'Argument' => \&req_Argument,
63 'Argumentx' => \&req_Argument,
64 'expand-modules' => \&req_expandmodules,
65 'add' => \&req_add,
66 'remove' => \&req_remove,
67 'co' => \&req_co,
68 'update' => \&req_update,
69 'ci' => \&req_ci,
70 'diff' => \&req_diff,
71 'log' => \&req_log,
72 'rlog' => \&req_log,
73 'tag' => \&req_CATCHALL,
74 'status' => \&req_status,
75 'admin' => \&req_CATCHALL,
76 'history' => \&req_CATCHALL,
77 'watchers' => \&req_EMPTY,
78 'editors' => \&req_EMPTY,
79 'annotate' => \&req_annotate,
80 'Global_option' => \&req_Globaloption,
81 #'annotate' => \&req_CATCHALL,
82 };
83
84 ##############################################
85
86
87 # $state holds all the bits of information the clients sends us that could
88 # potentially be useful when it comes to actually _doing_ something.
89 my $state = { prependdir => '' };
90
91 # Work is for managing temporary working directory
92 my $work =
93 {
94 state => undef, # undef, 1 (empty), 2 (with stuff)
95 workDir => undef,
96 index => undef,
97 emptyDir => undef,
98 tmpDir => undef
99 };
100
101 $log->info("--------------- STARTING -----------------");
102
103 my $usage =
104 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
105 " --base-path <path> : Prepend to requested CVSROOT\n".
106 " --strict-paths : Don't allow recursing into subdirectories\n".
107 " --export-all : Don't check for gitcvs.enabled in config\n".
108 " --version, -V : Print version information and exit\n".
109 " --help, -h, -H : Print usage information and exit\n".
110 "\n".
111 "<directory> ... is a list of allowed directories. If no directories\n".
112 "are given, all are allowed. This is an additional restriction, gitcvs\n".
113 "access still needs to be enabled by the gitcvs.enabled config option.\n";
114
115 my @opts = ( 'help|h|H', 'version|V',
116 'base-path=s', 'strict-paths', 'export-all' );
117 GetOptions( $state, @opts )
118 or die $usage;
119
120 if ($state->{version}) {
121 print "git-cvsserver version $VERSION\n";
122 exit;
123 }
124 if ($state->{help}) {
125 print $usage;
126 exit;
127 }
128
129 my $TEMP_DIR = tempdir( CLEANUP => 1 );
130 $log->debug("Temporary directory is '$TEMP_DIR'");
131
132 $state->{method} = 'ext';
133 if (@ARGV) {
134 if ($ARGV[0] eq 'pserver') {
135 $state->{method} = 'pserver';
136 shift @ARGV;
137 } elsif ($ARGV[0] eq 'server') {
138 shift @ARGV;
139 }
140 }
141
142 # everything else is a directory
143 $state->{allowed_roots} = [ @ARGV ];
144
145 # don't export the whole system unless the users requests it
146 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
147 die "--export-all can only be used together with an explicit whitelist\n";
148 }
149
150 # if we are called with a pserver argument,
151 # deal with the authentication cat before entering the
152 # main loop
153 if ($state->{method} eq 'pserver') {
154 my $line = <STDIN>; chomp $line;
155 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
156 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
157 }
158 my $request = $1;
159 $line = <STDIN>; chomp $line;
160 unless (req_Root('root', $line)) { # reuse Root
161 print "E Invalid root $line \n";
162 exit 1;
163 }
164 $line = <STDIN>; chomp $line;
165 unless ($line eq 'anonymous') {
166 print "E Only anonymous user allowed via pserver\n";
167 print "I HATE YOU\n";
168 exit 1;
169 }
170 $line = <STDIN>; chomp $line; # validate the password?
171 $line = <STDIN>; chomp $line;
172 unless ($line eq "END $request REQUEST") {
173 die "E Do not understand $line -- expecting END $request REQUEST\n";
174 }
175 print "I LOVE YOU\n";
176 exit if $request eq 'VERIFICATION'; # cvs login
177 # and now back to our regular programme...
178 }
179
180 # Keep going until the client closes the connection
181 while (<STDIN>)
182 {
183 chomp;
184
185 # Check to see if we've seen this method, and call appropriate function.
186 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
187 {
188 # use the $methods hash to call the appropriate sub for this command
189 #$log->info("Method : $1");
190 &{$methods->{$1}}($1,$2);
191 } else {
192 # log fatal because we don't understand this function. If this happens
193 # we're fairly screwed because we don't know if the client is expecting
194 # a response. If it is, the client will hang, we'll hang, and the whole
195 # thing will be custard.
196 $log->fatal("Don't understand command $_\n");
197 die("Unknown command $_");
198 }
199 }
200
201 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
202 $log->info("--------------- FINISH -----------------");
203
204 chdir '/';
205 exit 0;
206
207 # Magic catchall method.
208 # This is the method that will handle all commands we haven't yet
209 # implemented. It simply sends a warning to the log file indicating a
210 # command that hasn't been implemented has been invoked.
211 sub req_CATCHALL
212 {
213 my ( $cmd, $data ) = @_;
214 $log->warn("Unhandled command : req_$cmd : $data");
215 }
216
217 # This method invariably succeeds with an empty response.
218 sub req_EMPTY
219 {
220 print "ok\n";
221 }
222
223 # Root pathname \n
224 # Response expected: no. Tell the server which CVSROOT to use. Note that
225 # pathname is a local directory and not a fully qualified CVSROOT variable.
226 # pathname must already exist; if creating a new root, use the init
227 # request, not Root. pathname does not include the hostname of the server,
228 # how to access the server, etc.; by the time the CVS protocol is in use,
229 # connection, authentication, etc., are already taken care of. The Root
230 # request must be sent only once, and it must be sent before any requests
231 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
232 sub req_Root
233 {
234 my ( $cmd, $data ) = @_;
235 $log->debug("req_Root : $data");
236
237 unless ($data =~ m#^/#) {
238 print "error 1 Root must be an absolute pathname\n";
239 return 0;
240 }
241
242 my $cvsroot = $state->{'base-path'} || '';
243 $cvsroot =~ s#/+$##;
244 $cvsroot .= $data;
245
246 if ($state->{CVSROOT}
247 && ($state->{CVSROOT} ne $cvsroot)) {
248 print "error 1 Conflicting roots specified\n";
249 return 0;
250 }
251
252 $state->{CVSROOT} = $cvsroot;
253
254 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
255
256 if (@{$state->{allowed_roots}}) {
257 my $allowed = 0;
258 foreach my $dir (@{$state->{allowed_roots}}) {
259 next unless $dir =~ m#^/#;
260 $dir =~ s#/+$##;
261 if ($state->{'strict-paths'}) {
262 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
263 $allowed = 1;
264 last;
265 }
266 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
267 $allowed = 1;
268 last;
269 }
270 }
271
272 unless ($allowed) {
273 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
274 print "E \n";
275 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
276 return 0;
277 }
278 }
279
280 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
281 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
282 print "E \n";
283 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
284 return 0;
285 }
286
287 my @gitvars = `git-config -l`;
288 if ($?) {
289 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
290 print "E \n";
291 print "error 1 - problem executing git-config\n";
292 return 0;
293 }
294 foreach my $line ( @gitvars )
295 {
296 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
297 unless ($2) {
298 $cfg->{$1}{$3} = $4;
299 } else {
300 $cfg->{$1}{$2}{$3} = $4;
301 }
302 }
303
304 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
305 || $cfg->{gitcvs}{enabled});
306 unless ($state->{'export-all'} ||
307 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
308 print "E GITCVS emulation needs to be enabled on this repo\n";
309 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
310 print "E \n";
311 print "error 1 GITCVS emulation disabled\n";
312 return 0;
313 }
314
315 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
316 if ( $logfile )
317 {
318 $log->setfile($logfile);
319 } else {
320 $log->nofile();
321 }
322
323 return 1;
324 }
325
326 # Global_option option \n
327 # Response expected: no. Transmit one of the global options `-q', `-Q',
328 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
329 # variations (such as combining of options) are allowed. For graceful
330 # handling of valid-requests, it is probably better to make new global
331 # options separate requests, rather than trying to add them to this
332 # request.
333 sub req_Globaloption
334 {
335 my ( $cmd, $data ) = @_;
336 $log->debug("req_Globaloption : $data");
337 $state->{globaloptions}{$data} = 1;
338 }
339
340 # Valid-responses request-list \n
341 # Response expected: no. Tell the server what responses the client will
342 # accept. request-list is a space separated list of tokens.
343 sub req_Validresponses
344 {
345 my ( $cmd, $data ) = @_;
346 $log->debug("req_Validresponses : $data");
347
348 # TODO : re-enable this, currently it's not particularly useful
349 #$state->{validresponses} = [ split /\s+/, $data ];
350 }
351
352 # valid-requests \n
353 # Response expected: yes. Ask the server to send back a Valid-requests
354 # response.
355 sub req_validrequests
356 {
357 my ( $cmd, $data ) = @_;
358
359 $log->debug("req_validrequests");
360
361 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
362 $log->debug("SEND : ok");
363
364 print "Valid-requests " . join(" ",keys %$methods) . "\n";
365 print "ok\n";
366 }
367
368 # Directory local-directory \n
369 # Additional data: repository \n. Response expected: no. Tell the server
370 # what directory to use. The repository should be a directory name from a
371 # previous server response. Note that this both gives a default for Entry
372 # and Modified and also for ci and the other commands; normal usage is to
373 # send Directory for each directory in which there will be an Entry or
374 # Modified, and then a final Directory for the original directory, then the
375 # command. The local-directory is relative to the top level at which the
376 # command is occurring (i.e. the last Directory which is sent before the
377 # command); to indicate that top level, `.' should be sent for
378 # local-directory.
379 sub req_Directory
380 {
381 my ( $cmd, $data ) = @_;
382
383 my $repository = <STDIN>;
384 chomp $repository;
385
386
387 $state->{localdir} = $data;
388 $state->{repository} = $repository;
389 $state->{path} = $repository;
390 $state->{path} =~ s/^$state->{CVSROOT}\///;
391 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
392 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
393
394 $state->{directory} = $state->{localdir};
395 $state->{directory} = "" if ( $state->{directory} eq "." );
396 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
397
398 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
399 {
400 $log->info("Setting prepend to '$state->{path}'");
401 $state->{prependdir} = $state->{path};
402 foreach my $entry ( keys %{$state->{entries}} )
403 {
404 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
405 delete $state->{entries}{$entry};
406 }
407 }
408
409 if ( defined ( $state->{prependdir} ) )
410 {
411 $log->debug("Prepending '$state->{prependdir}' to state|directory");
412 $state->{directory} = $state->{prependdir} . $state->{directory}
413 }
414 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
415 }
416
417 # Entry entry-line \n
418 # Response expected: no. Tell the server what version of a file is on the
419 # local machine. The name in entry-line is a name relative to the directory
420 # most recently specified with Directory. If the user is operating on only
421 # some files in a directory, Entry requests for only those files need be
422 # included. If an Entry request is sent without Modified, Is-modified, or
423 # Unchanged, it means the file is lost (does not exist in the working
424 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
425 # are sent for the same file, Entry must be sent first. For a given file,
426 # one can send Modified, Is-modified, or Unchanged, but not more than one
427 # of these three.
428 sub req_Entry
429 {
430 my ( $cmd, $data ) = @_;
431
432 #$log->debug("req_Entry : $data");
433
434 my @data = split(/\//, $data);
435
436 $state->{entries}{$state->{directory}.$data[1]} = {
437 revision => $data[2],
438 conflict => $data[3],
439 options => $data[4],
440 tag_or_date => $data[5],
441 };
442
443 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
444 }
445
446 # Questionable filename \n
447 # Response expected: no. Additional data: no. Tell the server to check
448 # whether filename should be ignored, and if not, next time the server
449 # sends responses, send (in a M response) `?' followed by the directory and
450 # filename. filename must not contain `/'; it needs to be a file in the
451 # directory named by the most recent Directory request.
452 sub req_Questionable
453 {
454 my ( $cmd, $data ) = @_;
455
456 $log->debug("req_Questionable : $data");
457 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
458 }
459
460 # add \n
461 # Response expected: yes. Add a file or directory. This uses any previous
462 # Argument, Directory, Entry, or Modified requests, if they have been sent.
463 # The last Directory sent specifies the working directory at the time of
464 # the operation. To add a directory, send the directory to be added using
465 # Directory and Argument requests.
466 sub req_add
467 {
468 my ( $cmd, $data ) = @_;
469
470 argsplit("add");
471
472 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
473 $updater->update();
474
475 argsfromdir($updater);
476
477 my $addcount = 0;
478
479 foreach my $filename ( @{$state->{args}} )
480 {
481 $filename = filecleanup($filename);
482
483 my $meta = $updater->getmeta($filename);
484 my $wrev = revparse($filename);
485
486 if ($wrev && $meta && ($wrev < 0))
487 {
488 # previously removed file, add back
489 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
490
491 print "MT +updated\n";
492 print "MT text U \n";
493 print "MT fname $filename\n";
494 print "MT newline\n";
495 print "MT -updated\n";
496
497 unless ( $state->{globaloptions}{-n} )
498 {
499 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
500
501 print "Created $dirpart\n";
502 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
503
504 # this is an "entries" line
505 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
506 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
507 print "/$filepart/1.$meta->{revision}//$kopts/\n";
508 # permissions
509 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
510 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
511 # transmit file
512 transmitfile($meta->{filehash});
513 }
514
515 next;
516 }
517
518 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
519 {
520 print "E cvs add: nothing known about `$filename'\n";
521 next;
522 }
523 # TODO : check we're not squashing an already existing file
524 if ( defined ( $state->{entries}{$filename}{revision} ) )
525 {
526 print "E cvs add: `$filename' has already been entered\n";
527 next;
528 }
529
530 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
531
532 print "E cvs add: scheduling file `$filename' for addition\n";
533
534 print "Checked-in $dirpart\n";
535 print "$filename\n";
536 my $kopts = kopts_from_path($filename,"file",
537 $state->{entries}{$filename}{modified_filename});
538 print "/$filepart/0//$kopts/\n";
539
540 my $requestedKopts = $state->{opt}{k};
541 if(defined($requestedKopts))
542 {
543 $requestedKopts = "-k$requestedKopts";
544 }
545 else
546 {
547 $requestedKopts = "";
548 }
549 if( $kopts ne $requestedKopts )
550 {
551 $log->warn("Ignoring requested -k='$requestedKopts'"
552 . " for '$filename'; detected -k='$kopts' instead");
553 #TODO: Also have option to send warning to user?
554 }
555
556 $addcount++;
557 }
558
559 if ( $addcount == 1 )
560 {
561 print "E cvs add: use `cvs commit' to add this file permanently\n";
562 }
563 elsif ( $addcount > 1 )
564 {
565 print "E cvs add: use `cvs commit' to add these files permanently\n";
566 }
567
568 print "ok\n";
569 }
570
571 # remove \n
572 # Response expected: yes. Remove a file. This uses any previous Argument,
573 # Directory, Entry, or Modified requests, if they have been sent. The last
574 # Directory sent specifies the working directory at the time of the
575 # operation. Note that this request does not actually do anything to the
576 # repository; the only effect of a successful remove request is to supply
577 # the client with a new entries line containing `-' to indicate a removed
578 # file. In fact, the client probably could perform this operation without
579 # contacting the server, although using remove may cause the server to
580 # perform a few more checks. The client sends a subsequent ci request to
581 # actually record the removal in the repository.
582 sub req_remove
583 {
584 my ( $cmd, $data ) = @_;
585
586 argsplit("remove");
587
588 # Grab a handle to the SQLite db and do any necessary updates
589 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
590 $updater->update();
591
592 #$log->debug("add state : " . Dumper($state));
593
594 my $rmcount = 0;
595
596 foreach my $filename ( @{$state->{args}} )
597 {
598 $filename = filecleanup($filename);
599
600 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
601 {
602 print "E cvs remove: file `$filename' still in working directory\n";
603 next;
604 }
605
606 my $meta = $updater->getmeta($filename);
607 my $wrev = revparse($filename);
608
609 unless ( defined ( $wrev ) )
610 {
611 print "E cvs remove: nothing known about `$filename'\n";
612 next;
613 }
614
615 if ( defined($wrev) and $wrev < 0 )
616 {
617 print "E cvs remove: file `$filename' already scheduled for removal\n";
618 next;
619 }
620
621 unless ( $wrev == $meta->{revision} )
622 {
623 # TODO : not sure if the format of this message is quite correct.
624 print "E cvs remove: Up to date check failed for `$filename'\n";
625 next;
626 }
627
628
629 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
630
631 print "E cvs remove: scheduling `$filename' for removal\n";
632
633 print "Checked-in $dirpart\n";
634 print "$filename\n";
635 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
636 print "/$filepart/-1.$wrev//$kopts/\n";
637
638 $rmcount++;
639 }
640
641 if ( $rmcount == 1 )
642 {
643 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
644 }
645 elsif ( $rmcount > 1 )
646 {
647 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
648 }
649
650 print "ok\n";
651 }
652
653 # Modified filename \n
654 # Response expected: no. Additional data: mode, \n, file transmission. Send
655 # the server a copy of one locally modified file. filename is a file within
656 # the most recent directory sent with Directory; it must not contain `/'.
657 # If the user is operating on only some files in a directory, only those
658 # files need to be included. This can also be sent without Entry, if there
659 # is no entry for the file.
660 sub req_Modified
661 {
662 my ( $cmd, $data ) = @_;
663
664 my $mode = <STDIN>;
665 defined $mode
666 or (print "E end of file reading mode for $data\n"), return;
667 chomp $mode;
668 my $size = <STDIN>;
669 defined $size
670 or (print "E end of file reading size of $data\n"), return;
671 chomp $size;
672
673 # Grab config information
674 my $blocksize = 8192;
675 my $bytesleft = $size;
676 my $tmp;
677
678 # Get a filehandle/name to write it to
679 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
680
681 # Loop over file data writing out to temporary file.
682 while ( $bytesleft )
683 {
684 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
685 read STDIN, $tmp, $blocksize;
686 print $fh $tmp;
687 $bytesleft -= $blocksize;
688 }
689
690 close $fh
691 or (print "E failed to write temporary, $filename: $!\n"), return;
692
693 # Ensure we have something sensible for the file mode
694 if ( $mode =~ /u=(\w+)/ )
695 {
696 $mode = $1;
697 } else {
698 $mode = "rw";
699 }
700
701 # Save the file data in $state
702 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
703 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
704 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
705 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
706
707 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
708 }
709
710 # Unchanged filename \n
711 # Response expected: no. Tell the server that filename has not been
712 # modified in the checked out directory. The filename is a file within the
713 # most recent directory sent with Directory; it must not contain `/'.
714 sub req_Unchanged
715 {
716 my ( $cmd, $data ) = @_;
717
718 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
719
720 #$log->debug("req_Unchanged : $data");
721 }
722
723 # Argument text \n
724 # Response expected: no. Save argument for use in a subsequent command.
725 # Arguments accumulate until an argument-using command is given, at which
726 # point they are forgotten.
727 # Argumentx text \n
728 # Response expected: no. Append \n followed by text to the current argument
729 # being saved.
730 sub req_Argument
731 {
732 my ( $cmd, $data ) = @_;
733
734 # Argumentx means: append to last Argument (with a newline in front)
735
736 $log->debug("$cmd : $data");
737
738 if ( $cmd eq 'Argumentx') {
739 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
740 } else {
741 push @{$state->{arguments}}, $data;
742 }
743 }
744
745 # expand-modules \n
746 # Response expected: yes. Expand the modules which are specified in the
747 # arguments. Returns the data in Module-expansion responses. Note that the
748 # server can assume that this is checkout or export, not rtag or rdiff; the
749 # latter do not access the working directory and thus have no need to
750 # expand modules on the client side. Expand may not be the best word for
751 # what this request does. It does not necessarily tell you all the files
752 # contained in a module, for example. Basically it is a way of telling you
753 # which working directories the server needs to know about in order to
754 # handle a checkout of the specified modules. For example, suppose that the
755 # server has a module defined by
756 # aliasmodule -a 1dir
757 # That is, one can check out aliasmodule and it will take 1dir in the
758 # repository and check it out to 1dir in the working directory. Now suppose
759 # the client already has this module checked out and is planning on using
760 # the co request to update it. Without using expand-modules, the client
761 # would have two bad choices: it could either send information about all
762 # working directories under the current directory, which could be
763 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
764 # stands for 1dir, and neglect to send information for 1dir, which would
765 # lead to incorrect operation. With expand-modules, the client would first
766 # ask for the module to be expanded:
767 sub req_expandmodules
768 {
769 my ( $cmd, $data ) = @_;
770
771 argsplit();
772
773 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
774
775 unless ( ref $state->{arguments} eq "ARRAY" )
776 {
777 print "ok\n";
778 return;
779 }
780
781 foreach my $module ( @{$state->{arguments}} )
782 {
783 $log->debug("SEND : Module-expansion $module");
784 print "Module-expansion $module\n";
785 }
786
787 print "ok\n";
788 statecleanup();
789 }
790
791 # co \n
792 # Response expected: yes. Get files from the repository. This uses any
793 # previous Argument, Directory, Entry, or Modified requests, if they have
794 # been sent. Arguments to this command are module names; the client cannot
795 # know what directories they correspond to except by (1) just sending the
796 # co request, and then seeing what directory names the server sends back in
797 # its responses, and (2) the expand-modules request.
798 sub req_co
799 {
800 my ( $cmd, $data ) = @_;
801
802 argsplit("co");
803
804 my $module = $state->{args}[0];
805 $state->{module} = $module;
806 my $checkout_path = $module;
807
808 # use the user specified directory if we're given it
809 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
810
811 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
812
813 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
814
815 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
816
817 # Grab a handle to the SQLite db and do any necessary updates
818 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
819 $updater->update();
820
821 $checkout_path =~ s|/$||; # get rid of trailing slashes
822
823 # Eclipse seems to need the Clear-sticky command
824 # to prepare the 'Entries' file for the new directory.
825 print "Clear-sticky $checkout_path/\n";
826 print $state->{CVSROOT} . "/$module/\n";
827 print "Clear-static-directory $checkout_path/\n";
828 print $state->{CVSROOT} . "/$module/\n";
829 print "Clear-sticky $checkout_path/\n"; # yes, twice
830 print $state->{CVSROOT} . "/$module/\n";
831 print "Template $checkout_path/\n";
832 print $state->{CVSROOT} . "/$module/\n";
833 print "0\n";
834
835 # instruct the client that we're checking out to $checkout_path
836 print "E cvs checkout: Updating $checkout_path\n";
837
838 my %seendirs = ();
839 my $lastdir ='';
840
841 # recursive
842 sub prepdir {
843 my ($dir, $repodir, $remotedir, $seendirs) = @_;
844 my $parent = dirname($dir);
845 $dir =~ s|/+$||;
846 $repodir =~ s|/+$||;
847 $remotedir =~ s|/+$||;
848 $parent =~ s|/+$||;
849 $log->debug("announcedir $dir, $repodir, $remotedir" );
850
851 if ($parent eq '.' || $parent eq './') {
852 $parent = '';
853 }
854 # recurse to announce unseen parents first
855 if (length($parent) && !exists($seendirs->{$parent})) {
856 prepdir($parent, $repodir, $remotedir, $seendirs);
857 }
858 # Announce that we are going to modify at the parent level
859 if ($parent) {
860 print "E cvs checkout: Updating $remotedir/$parent\n";
861 } else {
862 print "E cvs checkout: Updating $remotedir\n";
863 }
864 print "Clear-sticky $remotedir/$parent/\n";
865 print "$repodir/$parent/\n";
866
867 print "Clear-static-directory $remotedir/$dir/\n";
868 print "$repodir/$dir/\n";
869 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
870 print "$repodir/$parent/\n";
871 print "Template $remotedir/$dir/\n";
872 print "$repodir/$dir/\n";
873 print "0\n";
874
875 $seendirs->{$dir} = 1;
876 }
877
878 foreach my $git ( @{$updater->gethead} )
879 {
880 # Don't want to check out deleted files
881 next if ( $git->{filehash} eq "deleted" );
882
883 my $fullName = $git->{name};
884 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
885
886 if (length($git->{dir}) && $git->{dir} ne './'
887 && $git->{dir} ne $lastdir ) {
888 unless (exists($seendirs{$git->{dir}})) {
889 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
890 $checkout_path, \%seendirs);
891 $lastdir = $git->{dir};
892 $seendirs{$git->{dir}} = 1;
893 }
894 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
895 }
896
897 # modification time of this file
898 print "Mod-time $git->{modified}\n";
899
900 # print some information to the client
901 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
902 {
903 print "M U $checkout_path/$git->{dir}$git->{name}\n";
904 } else {
905 print "M U $checkout_path/$git->{name}\n";
906 }
907
908 # instruct client we're sending a file to put in this path
909 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
910
911 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
912
913 # this is an "entries" line
914 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
915 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
916 # permissions
917 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
918
919 # transmit file
920 transmitfile($git->{filehash});
921 }
922
923 print "ok\n";
924
925 statecleanup();
926 }
927
928 # update \n
929 # Response expected: yes. Actually do a cvs update command. This uses any
930 # previous Argument, Directory, Entry, or Modified requests, if they have
931 # been sent. The last Directory sent specifies the working directory at the
932 # time of the operation. The -I option is not used--files which the client
933 # can decide whether to ignore are not mentioned and the client sends the
934 # Questionable request for others.
935 sub req_update
936 {
937 my ( $cmd, $data ) = @_;
938
939 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
940
941 argsplit("update");
942
943 #
944 # It may just be a client exploring the available heads/modules
945 # in that case, list them as top level directories and leave it
946 # at that. Eclipse uses this technique to offer you a list of
947 # projects (heads in this case) to checkout.
948 #
949 if ($state->{module} eq '') {
950 my $heads_dir = $state->{CVSROOT} . '/refs/heads';
951 if (!opendir HEADS, $heads_dir) {
952 print "E [server aborted]: Failed to open directory, "
953 . "$heads_dir: $!\nerror\n";
954 return 0;
955 }
956 print "E cvs update: Updating .\n";
957 while (my $head = readdir(HEADS)) {
958 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
959 print "E cvs update: New directory `$head'\n";
960 }
961 }
962 closedir HEADS;
963 print "ok\n";
964 return 1;
965 }
966
967
968 # Grab a handle to the SQLite db and do any necessary updates
969 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
970
971 $updater->update();
972
973 argsfromdir($updater);
974
975 #$log->debug("update state : " . Dumper($state));
976
977 # foreach file specified on the command line ...
978 foreach my $filename ( @{$state->{args}} )
979 {
980 $filename = filecleanup($filename);
981
982 $log->debug("Processing file $filename");
983
984 # if we have a -C we should pretend we never saw modified stuff
985 if ( exists ( $state->{opt}{C} ) )
986 {
987 delete $state->{entries}{$filename}{modified_hash};
988 delete $state->{entries}{$filename}{modified_filename};
989 $state->{entries}{$filename}{unchanged} = 1;
990 }
991
992 my $meta;
993 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
994 {
995 $meta = $updater->getmeta($filename, $1);
996 } else {
997 $meta = $updater->getmeta($filename);
998 }
999
1000 # If -p was given, "print" the contents of the requested revision.
1001 if ( exists ( $state->{opt}{p} ) ) {
1002 if ( defined ( $meta->{revision} ) ) {
1003 $log->info("Printing '$filename' revision " . $meta->{revision});
1004
1005 transmitfile($meta->{filehash}, { print => 1 });
1006 }
1007
1008 next;
1009 }
1010
1011 if ( ! defined $meta )
1012 {
1013 $meta = {
1014 name => $filename,
1015 revision => 0,
1016 filehash => 'added'
1017 };
1018 }
1019
1020 my $oldmeta = $meta;
1021
1022 my $wrev = revparse($filename);
1023
1024 # If the working copy is an old revision, lets get that version too for comparison.
1025 if ( defined($wrev) and $wrev != $meta->{revision} )
1026 {
1027 $oldmeta = $updater->getmeta($filename, $wrev);
1028 }
1029
1030 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1031
1032 # Files are up to date if the working copy and repo copy have the same revision,
1033 # and the working copy is unmodified _and_ the user hasn't specified -C
1034 next if ( defined ( $wrev )
1035 and defined($meta->{revision})
1036 and $wrev == $meta->{revision}
1037 and $state->{entries}{$filename}{unchanged}
1038 and not exists ( $state->{opt}{C} ) );
1039
1040 # If the working copy and repo copy have the same revision,
1041 # but the working copy is modified, tell the client it's modified
1042 if ( defined ( $wrev )
1043 and defined($meta->{revision})
1044 and $wrev == $meta->{revision}
1045 and defined($state->{entries}{$filename}{modified_hash})
1046 and not exists ( $state->{opt}{C} ) )
1047 {
1048 $log->info("Tell the client the file is modified");
1049 print "MT text M \n";
1050 print "MT fname $filename\n";
1051 print "MT newline\n";
1052 next;
1053 }
1054
1055 if ( $meta->{filehash} eq "deleted" )
1056 {
1057 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1058
1059 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1060
1061 print "E cvs update: `$filename' is no longer in the repository\n";
1062 # Don't want to actually _DO_ the update if -n specified
1063 unless ( $state->{globaloptions}{-n} ) {
1064 print "Removed $dirpart\n";
1065 print "$filepart\n";
1066 }
1067 }
1068 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1069 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1070 or $meta->{filehash} eq 'added' )
1071 {
1072 # normal update, just send the new revision (either U=Update,
1073 # or A=Add, or R=Remove)
1074 if ( defined($wrev) && $wrev < 0 )
1075 {
1076 $log->info("Tell the client the file is scheduled for removal");
1077 print "MT text R \n";
1078 print "MT fname $filename\n";
1079 print "MT newline\n";
1080 next;
1081 }
1082 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1083 {
1084 $log->info("Tell the client the file is scheduled for addition");
1085 print "MT text A \n";
1086 print "MT fname $filename\n";
1087 print "MT newline\n";
1088 next;
1089
1090 }
1091 else {
1092 $log->info("Updating '$filename' to ".$meta->{revision});
1093 print "MT +updated\n";
1094 print "MT text U \n";
1095 print "MT fname $filename\n";
1096 print "MT newline\n";
1097 print "MT -updated\n";
1098 }
1099
1100 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1101
1102 # Don't want to actually _DO_ the update if -n specified
1103 unless ( $state->{globaloptions}{-n} )
1104 {
1105 if ( defined ( $wrev ) )
1106 {
1107 # instruct client we're sending a file to put in this path as a replacement
1108 print "Update-existing $dirpart\n";
1109 $log->debug("Updating existing file 'Update-existing $dirpart'");
1110 } else {
1111 # instruct client we're sending a file to put in this path as a new file
1112 print "Clear-static-directory $dirpart\n";
1113 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1114 print "Clear-sticky $dirpart\n";
1115 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1116
1117 $log->debug("Creating new file 'Created $dirpart'");
1118 print "Created $dirpart\n";
1119 }
1120 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1121
1122 # this is an "entries" line
1123 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1124 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1125 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1126
1127 # permissions
1128 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1129 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1130
1131 # transmit file
1132 transmitfile($meta->{filehash});
1133 }
1134 } else {
1135 $log->info("Updating '$filename'");
1136 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1137
1138 my $mergeDir = setupTmpDir();
1139
1140 my $file_local = $filepart . ".mine";
1141 my $mergedFile = "$mergeDir/$file_local";
1142 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1143 my $file_old = $filepart . "." . $oldmeta->{revision};
1144 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1145 my $file_new = $filepart . "." . $meta->{revision};
1146 transmitfile($meta->{filehash}, { targetfile => $file_new });
1147
1148 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1149 $log->info("Merging $file_local, $file_old, $file_new");
1150 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1151
1152 $log->debug("Temporary directory for merge is $mergeDir");
1153
1154 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1155 $return >>= 8;
1156
1157 cleanupTmpDir();
1158
1159 if ( $return == 0 )
1160 {
1161 $log->info("Merged successfully");
1162 print "M M $filename\n";
1163 $log->debug("Merged $dirpart");
1164
1165 # Don't want to actually _DO_ the update if -n specified
1166 unless ( $state->{globaloptions}{-n} )
1167 {
1168 print "Merged $dirpart\n";
1169 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1170 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1171 my $kopts = kopts_from_path("$dirpart/$filepart",
1172 "file",$mergedFile);
1173 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1174 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1175 }
1176 }
1177 elsif ( $return == 1 )
1178 {
1179 $log->info("Merged with conflicts");
1180 print "E cvs update: conflicts found in $filename\n";
1181 print "M C $filename\n";
1182
1183 # Don't want to actually _DO_ the update if -n specified
1184 unless ( $state->{globaloptions}{-n} )
1185 {
1186 print "Merged $dirpart\n";
1187 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1188 my $kopts = kopts_from_path("$dirpart/$filepart",
1189 "file",$mergedFile);
1190 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1191 }
1192 }
1193 else
1194 {
1195 $log->warn("Merge failed");
1196 next;
1197 }
1198
1199 # Don't want to actually _DO_ the update if -n specified
1200 unless ( $state->{globaloptions}{-n} )
1201 {
1202 # permissions
1203 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1204 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1205
1206 # transmit file, format is single integer on a line by itself (file
1207 # size) followed by the file contents
1208 # TODO : we should copy files in blocks
1209 my $data = `cat $mergedFile`;
1210 $log->debug("File size : " . length($data));
1211 print length($data) . "\n";
1212 print $data;
1213 }
1214 }
1215
1216 }
1217
1218 print "ok\n";
1219 }
1220
1221 sub req_ci
1222 {
1223 my ( $cmd, $data ) = @_;
1224
1225 argsplit("ci");
1226
1227 #$log->debug("State : " . Dumper($state));
1228
1229 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1230
1231 if ( $state->{method} eq 'pserver')
1232 {
1233 print "error 1 pserver access cannot commit\n";
1234 cleanupWorkTree();
1235 exit;
1236 }
1237
1238 if ( -e $state->{CVSROOT} . "/index" )
1239 {
1240 $log->warn("file 'index' already exists in the git repository");
1241 print "error 1 Index already exists in git repo\n";
1242 cleanupWorkTree();
1243 exit;
1244 }
1245
1246 # Grab a handle to the SQLite db and do any necessary updates
1247 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1248 $updater->update();
1249
1250 # Remember where the head was at the beginning.
1251 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1252 chomp $parenthash;
1253 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1254 print "error 1 pserver cannot find the current HEAD of module";
1255 cleanupWorkTree();
1256 exit;
1257 }
1258
1259 setupWorkTree($parenthash);
1260
1261 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1262
1263 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1264
1265 my @committedfiles = ();
1266 my %oldmeta;
1267
1268 # foreach file specified on the command line ...
1269 foreach my $filename ( @{$state->{args}} )
1270 {
1271 my $committedfile = $filename;
1272 $filename = filecleanup($filename);
1273
1274 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1275
1276 my $meta = $updater->getmeta($filename);
1277 $oldmeta{$filename} = $meta;
1278
1279 my $wrev = revparse($filename);
1280
1281 my ( $filepart, $dirpart ) = filenamesplit($filename);
1282
1283 # do a checkout of the file if it is part of this tree
1284 if ($wrev) {
1285 system('git-checkout-index', '-f', '-u', $filename);
1286 unless ($? == 0) {
1287 die "Error running git-checkout-index -f -u $filename : $!";
1288 }
1289 }
1290
1291 my $addflag = 0;
1292 my $rmflag = 0;
1293 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1294 $addflag = 1 unless ( -e $filename );
1295
1296 # Do up to date checking
1297 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1298 {
1299 # fail everything if an up to date check fails
1300 print "error 1 Up to date check failed for $filename\n";
1301 cleanupWorkTree();
1302 exit;
1303 }
1304
1305 push @committedfiles, $committedfile;
1306 $log->info("Committing $filename");
1307
1308 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1309
1310 unless ( $rmflag )
1311 {
1312 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1313 rename $state->{entries}{$filename}{modified_filename},$filename;
1314
1315 # Calculate modes to remove
1316 my $invmode = "";
1317 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1318
1319 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1320 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1321 }
1322
1323 if ( $rmflag )
1324 {
1325 $log->info("Removing file '$filename'");
1326 unlink($filename);
1327 system("git-update-index", "--remove", $filename);
1328 }
1329 elsif ( $addflag )
1330 {
1331 $log->info("Adding file '$filename'");
1332 system("git-update-index", "--add", $filename);
1333 } else {
1334 $log->info("Updating file '$filename'");
1335 system("git-update-index", $filename);
1336 }
1337 }
1338
1339 unless ( scalar(@committedfiles) > 0 )
1340 {
1341 print "E No files to commit\n";
1342 print "ok\n";
1343 cleanupWorkTree();
1344 return;
1345 }
1346
1347 my $treehash = `git-write-tree`;
1348 chomp $treehash;
1349
1350 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1351
1352 # write our commit message out if we have one ...
1353 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1354 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1355 print $msg_fh "\n\nvia git-CVS emulator\n";
1356 close $msg_fh;
1357
1358 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1359 chomp($commithash);
1360 $log->info("Commit hash : $commithash");
1361
1362 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1363 {
1364 $log->warn("Commit failed (Invalid commit hash)");
1365 print "error 1 Commit failed (unknown reason)\n";
1366 cleanupWorkTree();
1367 exit;
1368 }
1369
1370 ### Emulate git-receive-pack by running hooks/update
1371 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1372 $parenthash, $commithash );
1373 if( -x $hook[0] ) {
1374 unless( system( @hook ) == 0 )
1375 {
1376 $log->warn("Commit failed (update hook declined to update ref)");
1377 print "error 1 Commit failed (update hook declined)\n";
1378 cleanupWorkTree();
1379 exit;
1380 }
1381 }
1382
1383 ### Update the ref
1384 if (system(qw(git update-ref -m), "cvsserver ci",
1385 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1386 $log->warn("update-ref for $state->{module} failed.");
1387 print "error 1 Cannot commit -- update first\n";
1388 cleanupWorkTree();
1389 exit;
1390 }
1391
1392 ### Emulate git-receive-pack by running hooks/post-receive
1393 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1394 if( -x $hook ) {
1395 open(my $pipe, "| $hook") || die "can't fork $!";
1396
1397 local $SIG{PIPE} = sub { die 'pipe broke' };
1398
1399 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1400
1401 close $pipe || die "bad pipe: $! $?";
1402 }
1403
1404 ### Then hooks/post-update
1405 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1406 if (-x $hook) {
1407 system($hook, "refs/heads/$state->{module}");
1408 }
1409
1410 $updater->update();
1411
1412 # foreach file specified on the command line ...
1413 foreach my $filename ( @committedfiles )
1414 {
1415 $filename = filecleanup($filename);
1416
1417 my $meta = $updater->getmeta($filename);
1418 unless (defined $meta->{revision}) {
1419 $meta->{revision} = 1;
1420 }
1421
1422 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1423
1424 $log->debug("Checked-in $dirpart : $filename");
1425
1426 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1427 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1428 {
1429 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1430 print "Remove-entry $dirpart\n";
1431 print "$filename\n";
1432 } else {
1433 if ($meta->{revision} == 1) {
1434 print "M initial revision: 1.1\n";
1435 } else {
1436 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1437 }
1438 print "Checked-in $dirpart\n";
1439 print "$filename\n";
1440 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1441 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1442 }
1443 }
1444
1445 cleanupWorkTree();
1446 print "ok\n";
1447 }
1448
1449 sub req_status
1450 {
1451 my ( $cmd, $data ) = @_;
1452
1453 argsplit("status");
1454
1455 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1456 #$log->debug("status state : " . Dumper($state));
1457
1458 # Grab a handle to the SQLite db and do any necessary updates
1459 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1460 $updater->update();
1461
1462 # if no files were specified, we need to work out what files we should be providing status on ...
1463 argsfromdir($updater);
1464
1465 # foreach file specified on the command line ...
1466 foreach my $filename ( @{$state->{args}} )
1467 {
1468 $filename = filecleanup($filename);
1469
1470 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1471
1472 my $meta = $updater->getmeta($filename);
1473 my $oldmeta = $meta;
1474
1475 my $wrev = revparse($filename);
1476
1477 # If the working copy is an old revision, lets get that version too for comparison.
1478 if ( defined($wrev) and $wrev != $meta->{revision} )
1479 {
1480 $oldmeta = $updater->getmeta($filename, $wrev);
1481 }
1482
1483 # TODO : All possible statuses aren't yet implemented
1484 my $status;
1485 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1486 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1487 and
1488 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1489 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1490 );
1491
1492 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1493 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1494 and
1495 ( $state->{entries}{$filename}{unchanged}
1496 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1497 );
1498
1499 # Need checkout if it exists in the repo but doesn't have a working copy
1500 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1501
1502 # Locally modified if working copy and repo copy have the same revision but there are local changes
1503 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1504
1505 # Needs Merge if working copy revision is less than repo copy and there are local changes
1506 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1507
1508 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1509 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1510 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1511 $status ||= "File had conflicts on merge" if ( 0 );
1512
1513 $status ||= "Unknown";
1514
1515 my ($filepart) = filenamesplit($filename);
1516
1517 print "M ===================================================================\n";
1518 print "M File: $filepart\tStatus: $status\n";
1519 if ( defined($state->{entries}{$filename}{revision}) )
1520 {
1521 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1522 } else {
1523 print "M Working revision:\tNo entry for $filename\n";
1524 }
1525 if ( defined($meta->{revision}) )
1526 {
1527 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1528 print "M Sticky Tag:\t\t(none)\n";
1529 print "M Sticky Date:\t\t(none)\n";
1530 print "M Sticky Options:\t\t(none)\n";
1531 } else {
1532 print "M Repository revision:\tNo revision control file\n";
1533 }
1534 print "M\n";
1535 }
1536
1537 print "ok\n";
1538 }
1539
1540 sub req_diff
1541 {
1542 my ( $cmd, $data ) = @_;
1543
1544 argsplit("diff");
1545
1546 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1547 #$log->debug("status state : " . Dumper($state));
1548
1549 my ($revision1, $revision2);
1550 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1551 {
1552 $revision1 = $state->{opt}{r}[0];
1553 $revision2 = $state->{opt}{r}[1];
1554 } else {
1555 $revision1 = $state->{opt}{r};
1556 }
1557
1558 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1559 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1560
1561 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1562
1563 # Grab a handle to the SQLite db and do any necessary updates
1564 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1565 $updater->update();
1566
1567 # if no files were specified, we need to work out what files we should be providing status on ...
1568 argsfromdir($updater);
1569
1570 # foreach file specified on the command line ...
1571 foreach my $filename ( @{$state->{args}} )
1572 {
1573 $filename = filecleanup($filename);
1574
1575 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1576
1577 my $wrev = revparse($filename);
1578
1579 # We need _something_ to diff against
1580 next unless ( defined ( $wrev ) );
1581
1582 # if we have a -r switch, use it
1583 if ( defined ( $revision1 ) )
1584 {
1585 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1586 $meta1 = $updater->getmeta($filename, $revision1);
1587 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1588 {
1589 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1590 next;
1591 }
1592 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1593 }
1594 # otherwise we just use the working copy revision
1595 else
1596 {
1597 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1598 $meta1 = $updater->getmeta($filename, $wrev);
1599 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1600 }
1601
1602 # if we have a second -r switch, use it too
1603 if ( defined ( $revision2 ) )
1604 {
1605 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1606 $meta2 = $updater->getmeta($filename, $revision2);
1607
1608 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1609 {
1610 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1611 next;
1612 }
1613
1614 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1615 }
1616 # otherwise we just use the working copy
1617 else
1618 {
1619 $file2 = $state->{entries}{$filename}{modified_filename};
1620 }
1621
1622 # if we have been given -r, and we don't have a $file2 yet, lets get one
1623 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1624 {
1625 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1626 $meta2 = $updater->getmeta($filename, $wrev);
1627 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1628 }
1629
1630 # We need to have retrieved something useful
1631 next unless ( defined ( $meta1 ) );
1632
1633 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1634 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1635 and
1636 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1637 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1638 );
1639
1640 # Apparently we only show diffs for locally modified files
1641 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1642
1643 print "M Index: $filename\n";
1644 print "M ===================================================================\n";
1645 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1646 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1647 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1648 print "M diff ";
1649 foreach my $opt ( keys %{$state->{opt}} )
1650 {
1651 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1652 {
1653 foreach my $value ( @{$state->{opt}{$opt}} )
1654 {
1655 print "-$opt $value ";
1656 }
1657 } else {
1658 print "-$opt ";
1659 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1660 }
1661 }
1662 print "$filename\n";
1663
1664 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1665
1666 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1667
1668 if ( exists $state->{opt}{u} )
1669 {
1670 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1671 } else {
1672 system("diff $file1 $file2 > $filediff");
1673 }
1674
1675 while ( <$fh> )
1676 {
1677 print "M $_";
1678 }
1679 close $fh;
1680 }
1681
1682 print "ok\n";
1683 }
1684
1685 sub req_log
1686 {
1687 my ( $cmd, $data ) = @_;
1688
1689 argsplit("log");
1690
1691 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1692 #$log->debug("log state : " . Dumper($state));
1693
1694 my ( $minrev, $maxrev );
1695 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1696 {
1697 my $control = $2;
1698 $minrev = $1;
1699 $maxrev = $3;
1700 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1701 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1702 $minrev++ if ( defined($minrev) and $control eq "::" );
1703 }
1704
1705 # Grab a handle to the SQLite db and do any necessary updates
1706 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1707 $updater->update();
1708
1709 # if no files were specified, we need to work out what files we should be providing status on ...
1710 argsfromdir($updater);
1711
1712 # foreach file specified on the command line ...
1713 foreach my $filename ( @{$state->{args}} )
1714 {
1715 $filename = filecleanup($filename);
1716
1717 my $headmeta = $updater->getmeta($filename);
1718
1719 my $revisions = $updater->getlog($filename);
1720 my $totalrevisions = scalar(@$revisions);
1721
1722 if ( defined ( $minrev ) )
1723 {
1724 $log->debug("Removing revisions less than $minrev");
1725 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1726 {
1727 pop @$revisions;
1728 }
1729 }
1730 if ( defined ( $maxrev ) )
1731 {
1732 $log->debug("Removing revisions greater than $maxrev");
1733 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1734 {
1735 shift @$revisions;
1736 }
1737 }
1738
1739 next unless ( scalar(@$revisions) );
1740
1741 print "M \n";
1742 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1743 print "M Working file: $filename\n";
1744 print "M head: 1.$headmeta->{revision}\n";
1745 print "M branch:\n";
1746 print "M locks: strict\n";
1747 print "M access list:\n";
1748 print "M symbolic names:\n";
1749 print "M keyword substitution: kv\n";
1750 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1751 print "M description:\n";
1752
1753 foreach my $revision ( @$revisions )
1754 {
1755 print "M ----------------------------\n";
1756 print "M revision 1.$revision->{revision}\n";
1757 # reformat the date for log output
1758 $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}) );
1759 $revision->{author} = cvs_author($revision->{author});
1760 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1761 my $commitmessage = $updater->commitmessage($revision->{commithash});
1762 $commitmessage =~ s/^/M /mg;
1763 print $commitmessage . "\n";
1764 }
1765 print "M =============================================================================\n";
1766 }
1767
1768 print "ok\n";
1769 }
1770
1771 sub req_annotate
1772 {
1773 my ( $cmd, $data ) = @_;
1774
1775 argsplit("annotate");
1776
1777 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1778 #$log->debug("status state : " . Dumper($state));
1779
1780 # Grab a handle to the SQLite db and do any necessary updates
1781 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1782 $updater->update();
1783
1784 # if no files were specified, we need to work out what files we should be providing annotate on ...
1785 argsfromdir($updater);
1786
1787 # we'll need a temporary checkout dir
1788 setupWorkTree();
1789
1790 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1791
1792 # foreach file specified on the command line ...
1793 foreach my $filename ( @{$state->{args}} )
1794 {
1795 $filename = filecleanup($filename);
1796
1797 my $meta = $updater->getmeta($filename);
1798
1799 next unless ( $meta->{revision} );
1800
1801 # get all the commits that this file was in
1802 # in dense format -- aka skip dead revisions
1803 my $revisions = $updater->gethistorydense($filename);
1804 my $lastseenin = $revisions->[0][2];
1805
1806 # populate the temporary index based on the latest commit were we saw
1807 # the file -- but do it cheaply without checking out any files
1808 # TODO: if we got a revision from the client, use that instead
1809 # to look up the commithash in sqlite (still good to default to
1810 # the current head as we do now)
1811 system("git-read-tree", $lastseenin);
1812 unless ($? == 0)
1813 {
1814 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1815 return;
1816 }
1817 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1818
1819 # do a checkout of the file
1820 system('git-checkout-index', '-f', '-u', $filename);
1821 unless ($? == 0) {
1822 print "E error running git-checkout-index -f -u $filename : $!\n";
1823 return;
1824 }
1825
1826 $log->info("Annotate $filename");
1827
1828 # Prepare a file with the commits from the linearized
1829 # history that annotate should know about. This prevents
1830 # git-jsannotate telling us about commits we are hiding
1831 # from the client.
1832
1833 my $a_hints = "$work->{workDir}/.annotate_hints";
1834 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1835 print "E failed to open '$a_hints' for writing: $!\n";
1836 return;
1837 }
1838 for (my $i=0; $i < @$revisions; $i++)
1839 {
1840 print ANNOTATEHINTS $revisions->[$i][2];
1841 if ($i+1 < @$revisions) { # have we got a parent?
1842 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1843 }
1844 print ANNOTATEHINTS "\n";
1845 }
1846
1847 print ANNOTATEHINTS "\n";
1848 close ANNOTATEHINTS
1849 or (print "E failed to write $a_hints: $!\n"), return;
1850
1851 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1852 if (!open(ANNOTATE, "-|", @cmd)) {
1853 print "E error invoking ". join(' ',@cmd) .": $!\n";
1854 return;
1855 }
1856 my $metadata = {};
1857 print "E Annotations for $filename\n";
1858 print "E ***************\n";
1859 while ( <ANNOTATE> )
1860 {
1861 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1862 {
1863 my $commithash = $1;
1864 my $data = $2;
1865 unless ( defined ( $metadata->{$commithash} ) )
1866 {
1867 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1868 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1869 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1870 }
1871 printf("M 1.%-5d (%-8s %10s): %s\n",
1872 $metadata->{$commithash}{revision},
1873 $metadata->{$commithash}{author},
1874 $metadata->{$commithash}{modified},
1875 $data
1876 );
1877 } else {
1878 $log->warn("Error in annotate output! LINE: $_");
1879 print "E Annotate error \n";
1880 next;
1881 }
1882 }
1883 close ANNOTATE;
1884 }
1885
1886 # done; get out of the tempdir
1887 cleanupWorkTree();
1888
1889 print "ok\n";
1890
1891 }
1892
1893 # This method takes the state->{arguments} array and produces two new arrays.
1894 # The first is $state->{args} which is everything before the '--' argument, and
1895 # the second is $state->{files} which is everything after it.
1896 sub argsplit
1897 {
1898 $state->{args} = [];
1899 $state->{files} = [];
1900 $state->{opt} = {};
1901
1902 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1903
1904 my $type = shift;
1905
1906 if ( defined($type) )
1907 {
1908 my $opt = {};
1909 $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" );
1910 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1911 $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" );
1912 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1913 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1914 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1915 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1916 $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" );
1917
1918
1919 while ( scalar ( @{$state->{arguments}} ) > 0 )
1920 {
1921 my $arg = shift @{$state->{arguments}};
1922
1923 next if ( $arg eq "--" );
1924 next unless ( $arg =~ /\S/ );
1925
1926 # if the argument looks like a switch
1927 if ( $arg =~ /^-(\w)(.*)/ )
1928 {
1929 # if it's a switch that takes an argument
1930 if ( $opt->{$1} )
1931 {
1932 # If this switch has already been provided
1933 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1934 {
1935 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1936 if ( length($2) > 0 )
1937 {
1938 push @{$state->{opt}{$1}},$2;
1939 } else {
1940 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1941 }
1942 } else {
1943 # if there's extra data in the arg, use that as the argument for the switch
1944 if ( length($2) > 0 )
1945 {
1946 $state->{opt}{$1} = $2;
1947 } else {
1948 $state->{opt}{$1} = shift @{$state->{arguments}};
1949 }
1950 }
1951 } else {
1952 $state->{opt}{$1} = undef;
1953 }
1954 }
1955 else
1956 {
1957 push @{$state->{args}}, $arg;
1958 }
1959 }
1960 }
1961 else
1962 {
1963 my $mode = 0;
1964
1965 foreach my $value ( @{$state->{arguments}} )
1966 {
1967 if ( $value eq "--" )
1968 {
1969 $mode++;
1970 next;
1971 }
1972 push @{$state->{args}}, $value if ( $mode == 0 );
1973 push @{$state->{files}}, $value if ( $mode == 1 );
1974 }
1975 }
1976 }
1977
1978 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1979 sub argsfromdir
1980 {
1981 my $updater = shift;
1982
1983 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1984
1985 return if ( scalar ( @{$state->{args}} ) > 1 );
1986
1987 my @gethead = @{$updater->gethead};
1988
1989 # push added files
1990 foreach my $file (keys %{$state->{entries}}) {
1991 if ( exists $state->{entries}{$file}{revision} &&
1992 $state->{entries}{$file}{revision} == 0 )
1993 {
1994 push @gethead, { name => $file, filehash => 'added' };
1995 }
1996 }
1997
1998 if ( scalar(@{$state->{args}}) == 1 )
1999 {
2000 my $arg = $state->{args}[0];
2001 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2002
2003 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2004
2005 foreach my $file ( @gethead )
2006 {
2007 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2008 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2009 push @{$state->{args}}, $file->{name};
2010 }
2011
2012 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2013 } else {
2014 $log->info("Only one arg specified, populating file list automatically");
2015
2016 $state->{args} = [];
2017
2018 foreach my $file ( @gethead )
2019 {
2020 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2021 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2022 push @{$state->{args}}, $file->{name};
2023 }
2024 }
2025 }
2026
2027 # This method cleans up the $state variable after a command that uses arguments has run
2028 sub statecleanup
2029 {
2030 $state->{files} = [];
2031 $state->{args} = [];
2032 $state->{arguments} = [];
2033 $state->{entries} = {};
2034 }
2035
2036 sub revparse
2037 {
2038 my $filename = shift;
2039
2040 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2041
2042 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2043 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2044
2045 return undef;
2046 }
2047
2048 # This method takes a file hash and does a CVS "file transfer". Its
2049 # exact behaviour depends on a second, optional hash table argument:
2050 # - If $options->{targetfile}, dump the contents to that file;
2051 # - If $options->{print}, use M/MT to transmit the contents one line
2052 # at a time;
2053 # - Otherwise, transmit the size of the file, followed by the file
2054 # contents.
2055 sub transmitfile
2056 {
2057 my $filehash = shift;
2058 my $options = shift;
2059
2060 if ( defined ( $filehash ) and $filehash eq "deleted" )
2061 {
2062 $log->warn("filehash is 'deleted'");
2063 return;
2064 }
2065
2066 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2067
2068 my $type = `git-cat-file -t $filehash`;
2069 chomp $type;
2070
2071 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2072
2073 my $size = `git-cat-file -s $filehash`;
2074 chomp $size;
2075
2076 $log->debug("transmitfile($filehash) size=$size, type=$type");
2077
2078 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2079 {
2080 if ( defined ( $options->{targetfile} ) )
2081 {
2082 my $targetfile = $options->{targetfile};
2083 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2084 print NEWFILE $_ while ( <$fh> );
2085 close NEWFILE or die("Failed to write '$targetfile': $!");
2086 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2087 while ( <$fh> ) {
2088 if( /\n\z/ ) {
2089 print 'M ', $_;
2090 } else {
2091 print 'MT text ', $_, "\n";
2092 }
2093 }
2094 } else {
2095 print "$size\n";
2096 print while ( <$fh> );
2097 }
2098 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2099 } else {
2100 die("Couldn't execute git-cat-file");
2101 }
2102 }
2103
2104 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2105 # refers to the directory portion and the file portion of the filename
2106 # respectively
2107 sub filenamesplit
2108 {
2109 my $filename = shift;
2110 my $fixforlocaldir = shift;
2111
2112 my ( $filepart, $dirpart ) = ( $filename, "." );
2113 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2114 $dirpart .= "/";
2115
2116 if ( $fixforlocaldir )
2117 {
2118 $dirpart =~ s/^$state->{prependdir}//;
2119 }
2120
2121 return ( $filepart, $dirpart );
2122 }
2123
2124 sub filecleanup
2125 {
2126 my $filename = shift;
2127
2128 return undef unless(defined($filename));
2129 if ( $filename =~ /^\// )
2130 {
2131 print "E absolute filenames '$filename' not supported by server\n";
2132 return undef;
2133 }
2134
2135 $filename =~ s/^\.\///g;
2136 $filename = $state->{prependdir} . $filename;
2137 return $filename;
2138 }
2139
2140 sub validateGitDir
2141 {
2142 if( !defined($state->{CVSROOT}) )
2143 {
2144 print "error 1 CVSROOT not specified\n";
2145 cleanupWorkTree();
2146 exit;
2147 }
2148 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2149 {
2150 print "error 1 Internally inconsistent CVSROOT\n";
2151 cleanupWorkTree();
2152 exit;
2153 }
2154 }
2155
2156 # Setup working directory in a work tree with the requested version
2157 # loaded in the index.
2158 sub setupWorkTree
2159 {
2160 my ($ver) = @_;
2161
2162 validateGitDir();
2163
2164 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2165 defined($work->{tmpDir}) )
2166 {
2167 $log->warn("Bad work tree state management");
2168 print "error 1 Internal setup multiple work trees without cleanup\n";
2169 cleanupWorkTree();
2170 exit;
2171 }
2172
2173 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2174
2175 if( !defined($work->{index}) )
2176 {
2177 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2178 }
2179
2180 chdir $work->{workDir} or
2181 die "Unable to chdir to $work->{workDir}\n";
2182
2183 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2184
2185 $ENV{GIT_WORK_TREE} = ".";
2186 $ENV{GIT_INDEX_FILE} = $work->{index};
2187 $work->{state} = 2;
2188
2189 if($ver)
2190 {
2191 system("git","read-tree",$ver);
2192 unless ($? == 0)
2193 {
2194 $log->warn("Error running git-read-tree");
2195 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2196 }
2197 }
2198 # else # req_annotate reads tree for each file
2199 }
2200
2201 # Ensure current directory is in some kind of working directory,
2202 # with a recent version loaded in the index.
2203 sub ensureWorkTree
2204 {
2205 if( defined($work->{tmpDir}) )
2206 {
2207 $log->warn("Bad work tree state management [ensureWorkTree()]");
2208 print "error 1 Internal setup multiple dirs without cleanup\n";
2209 cleanupWorkTree();
2210 exit;
2211 }
2212 if( $work->{state} )
2213 {
2214 return;
2215 }
2216
2217 validateGitDir();
2218
2219 if( !defined($work->{emptyDir}) )
2220 {
2221 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2222 }
2223 chdir $work->{emptyDir} or
2224 die "Unable to chdir to $work->{emptyDir}\n";
2225
2226 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2227 chomp $ver;
2228 if ($ver !~ /^[0-9a-f]{40}$/)
2229 {
2230 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2231 print "error 1 cannot find the current HEAD of module";
2232 cleanupWorkTree();
2233 exit;
2234 }
2235
2236 if( !defined($work->{index}) )
2237 {
2238 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2239 }
2240
2241 $ENV{GIT_WORK_TREE} = ".";
2242 $ENV{GIT_INDEX_FILE} = $work->{index};
2243 $work->{state} = 1;
2244
2245 system("git","read-tree",$ver);
2246 unless ($? == 0)
2247 {
2248 die "Error running git-read-tree $ver $!\n";
2249 }
2250 }
2251
2252 # Cleanup working directory that is not needed any longer.
2253 sub cleanupWorkTree
2254 {
2255 if( ! $work->{state} )
2256 {
2257 return;
2258 }
2259
2260 chdir "/" or die "Unable to chdir '/'\n";
2261
2262 if( defined($work->{workDir}) )
2263 {
2264 rmtree( $work->{workDir} );
2265 undef $work->{workDir};
2266 }
2267 undef $work->{state};
2268 }
2269
2270 # Setup a temporary directory (not a working tree), typically for
2271 # merging dirty state as in req_update.
2272 sub setupTmpDir
2273 {
2274 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2275 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2276
2277 return $work->{tmpDir};
2278 }
2279
2280 # Clean up a previously setupTmpDir. Restore previous work tree if
2281 # appropriate.
2282 sub cleanupTmpDir
2283 {
2284 if ( !defined($work->{tmpDir}) )
2285 {
2286 $log->warn("cleanup tmpdir that has not been setup");
2287 die "Cleanup tmpDir that has not been setup\n";
2288 }
2289 if( defined($work->{state}) )
2290 {
2291 if( $work->{state} == 1 )
2292 {
2293 chdir $work->{emptyDir} or
2294 die "Unable to chdir to $work->{emptyDir}\n";
2295 }
2296 elsif( $work->{state} == 2 )
2297 {
2298 chdir $work->{workDir} or
2299 die "Unable to chdir to $work->{emptyDir}\n";
2300 }
2301 else
2302 {
2303 $log->warn("Inconsistent work dir state");
2304 die "Inconsistent work dir state\n";
2305 }
2306 }
2307 else
2308 {
2309 chdir "/" or die "Unable to chdir '/'\n";
2310 }
2311 }
2312
2313 # Given a path, this function returns a string containing the kopts
2314 # that should go into that path's Entries line. For example, a binary
2315 # file should get -kb.
2316 sub kopts_from_path
2317 {
2318 my ($path, $srcType, $name) = @_;
2319
2320 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2321 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2322 {
2323 my ($val) = check_attr( "crlf", $path );
2324 if ( $val eq "set" )
2325 {
2326 return "";
2327 }
2328 elsif ( $val eq "unset" )
2329 {
2330 return "-kb"
2331 }
2332 else
2333 {
2334 $log->info("Unrecognized check_attr crlf $path : $val");
2335 }
2336 }
2337
2338 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2339 {
2340 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2341 {
2342 return "-kb";
2343 }
2344 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2345 {
2346 if( $srcType eq "sha1Or-k" &&
2347 !defined($name) )
2348 {
2349 my ($ret)=$state->{entries}{$path}{options};
2350 if( !defined($ret) )
2351 {
2352 $ret=$state->{opt}{k};
2353 if(defined($ret))
2354 {
2355 $ret="-k$ret";
2356 }
2357 else
2358 {
2359 $ret="";
2360 }
2361 }
2362 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2363 {
2364 print "E Bad -k option\n";
2365 $log->warn("Bad -k option: $ret");
2366 die "Error: Bad -k option: $ret\n";
2367 }
2368
2369 return $ret;
2370 }
2371 else
2372 {
2373 if( is_binary($srcType,$name) )
2374 {
2375 $log->debug("... as binary");
2376 return "-kb";
2377 }
2378 else
2379 {
2380 $log->debug("... as text");
2381 }
2382 }
2383 }
2384 }
2385 # Return "" to give no special treatment to any path
2386 return "";
2387 }
2388
2389 sub check_attr
2390 {
2391 my ($attr,$path) = @_;
2392 ensureWorkTree();
2393 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2394 {
2395 my $val = <$fh>;
2396 close $fh;
2397 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2398 return $val;
2399 }
2400 else
2401 {
2402 return undef;
2403 }
2404 }
2405
2406 # This should have the same heuristics as convert.c:is_binary() and related.
2407 # Note that the bare CR test is done by callers in convert.c.
2408 sub is_binary
2409 {
2410 my ($srcType,$name) = @_;
2411 $log->debug("is_binary($srcType,$name)");
2412
2413 # Minimize amount of interpreted code run in the inner per-character
2414 # loop for large files, by totalling each character value and
2415 # then analyzing the totals.
2416 my @counts;
2417 my $i;
2418 for($i=0;$i<256;$i++)
2419 {
2420 $counts[$i]=0;
2421 }
2422
2423 my $fh = open_blob_or_die($srcType,$name);
2424 my $line;
2425 while( defined($line=<$fh>) )
2426 {
2427 # Any '\0' and bare CR are considered binary.
2428 if( $line =~ /\0|(\r[^\n])/ )
2429 {
2430 close($fh);
2431 return 1;
2432 }
2433
2434 # Count up each character in the line:
2435 my $len=length($line);
2436 for($i=0;$i<$len;$i++)
2437 {
2438 $counts[ord(substr($line,$i,1))]++;
2439 }
2440 }
2441 close $fh;
2442
2443 # Don't count CR and LF as either printable/nonprintable
2444 $counts[ord("\n")]=0;
2445 $counts[ord("\r")]=0;
2446
2447 # Categorize individual character count into printable and nonprintable:
2448 my $printable=0;
2449 my $nonprintable=0;
2450 for($i=0;$i<256;$i++)
2451 {
2452 if( $i < 32 &&
2453 $i != ord("\b") &&
2454 $i != ord("\t") &&
2455 $i != 033 && # ESC
2456 $i != 014 ) # FF
2457 {
2458 $nonprintable+=$counts[$i];
2459 }
2460 elsif( $i==127 ) # DEL
2461 {
2462 $nonprintable+=$counts[$i];
2463 }
2464 else
2465 {
2466 $printable+=$counts[$i];
2467 }
2468 }
2469
2470 return ($printable >> 7) < $nonprintable;
2471 }
2472
2473 # Returns open file handle. Possible invocations:
2474 # - open_blob_or_die("file",$filename);
2475 # - open_blob_or_die("sha1",$filehash);
2476 sub open_blob_or_die
2477 {
2478 my ($srcType,$name) = @_;
2479 my ($fh);
2480 if( $srcType eq "file" )
2481 {
2482 if( !open $fh,"<",$name )
2483 {
2484 $log->warn("Unable to open file $name: $!");
2485 die "Unable to open file $name: $!\n";
2486 }
2487 }
2488 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2489 {
2490 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2491 {
2492 $log->warn("Need filehash");
2493 die "Need filehash\n";
2494 }
2495
2496 my $type = `git cat-file -t $name`;
2497 chomp $type;
2498
2499 unless ( defined ( $type ) and $type eq "blob" )
2500 {
2501 $log->warn("Invalid type '$type' for '$name'");
2502 die ( "Invalid type '$type' (expected 'blob')" )
2503 }
2504
2505 my $size = `git cat-file -s $name`;
2506 chomp $size;
2507
2508 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2509
2510 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2511 {
2512 $log->warn("Unable to open sha1 $name");
2513 die "Unable to open sha1 $name\n";
2514 }
2515 }
2516 else
2517 {
2518 $log->warn("Unknown type of blob source: $srcType");
2519 die "Unknown type of blob source: $srcType\n";
2520 }
2521 return $fh;
2522 }
2523
2524 # Generate a CVS author name from Git author information, by taking
2525 # the first eight characters of the user part of the email address.
2526 sub cvs_author
2527 {
2528 my $author_line = shift;
2529 (my $author) = $author_line =~ /<([^>@]{1,8})/;
2530
2531 $author;
2532 }
2533
2534 package GITCVS::log;
2535
2536 ####
2537 #### Copyright The Open University UK - 2006.
2538 ####
2539 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2540 #### Martin Langhoff <martin@catalyst.net.nz>
2541 ####
2542 ####
2543
2544 use strict;
2545 use warnings;
2546
2547 =head1 NAME
2548
2549 GITCVS::log
2550
2551 =head1 DESCRIPTION
2552
2553 This module provides very crude logging with a similar interface to
2554 Log::Log4perl
2555
2556 =head1 METHODS
2557
2558 =cut
2559
2560 =head2 new
2561
2562 Creates a new log object, optionally you can specify a filename here to
2563 indicate the file to log to. If no log file is specified, you can specify one
2564 later with method setfile, or indicate you no longer want logging with method
2565 nofile.
2566
2567 Until one of these methods is called, all log calls will buffer messages ready
2568 to write out.
2569
2570 =cut
2571 sub new
2572 {
2573 my $class = shift;
2574 my $filename = shift;
2575
2576 my $self = {};
2577
2578 bless $self, $class;
2579
2580 if ( defined ( $filename ) )
2581 {
2582 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2583 }
2584
2585 return $self;
2586 }
2587
2588 =head2 setfile
2589
2590 This methods takes a filename, and attempts to open that file as the log file.
2591 If successful, all buffered data is written out to the file, and any further
2592 logging is written directly to the file.
2593
2594 =cut
2595 sub setfile
2596 {
2597 my $self = shift;
2598 my $filename = shift;
2599
2600 if ( defined ( $filename ) )
2601 {
2602 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2603 }
2604
2605 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2606
2607 while ( my $line = shift @{$self->{buffer}} )
2608 {
2609 print {$self->{fh}} $line;
2610 }
2611 }
2612
2613 =head2 nofile
2614
2615 This method indicates no logging is going to be used. It flushes any entries in
2616 the internal buffer, and sets a flag to ensure no further data is put there.
2617
2618 =cut
2619 sub nofile
2620 {
2621 my $self = shift;
2622
2623 $self->{nolog} = 1;
2624
2625 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2626
2627 $self->{buffer} = [];
2628 }
2629
2630 =head2 _logopen
2631
2632 Internal method. Returns true if the log file is open, false otherwise.
2633
2634 =cut
2635 sub _logopen
2636 {
2637 my $self = shift;
2638
2639 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2640 return 0;
2641 }
2642
2643 =head2 debug info warn fatal
2644
2645 These four methods are wrappers to _log. They provide the actual interface for
2646 logging data.
2647
2648 =cut
2649 sub debug { my $self = shift; $self->_log("debug", @_); }
2650 sub info { my $self = shift; $self->_log("info" , @_); }
2651 sub warn { my $self = shift; $self->_log("warn" , @_); }
2652 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2653
2654 =head2 _log
2655
2656 This is an internal method called by the logging functions. It generates a
2657 timestamp and pushes the logged line either to file, or internal buffer.
2658
2659 =cut
2660 sub _log
2661 {
2662 my $self = shift;
2663 my $level = shift;
2664
2665 return if ( $self->{nolog} );
2666
2667 my @time = localtime;
2668 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2669 $time[5] + 1900,
2670 $time[4] + 1,
2671 $time[3],
2672 $time[2],
2673 $time[1],
2674 $time[0],
2675 uc $level,
2676 );
2677
2678 if ( $self->_logopen )
2679 {
2680 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2681 } else {
2682 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2683 }
2684 }
2685
2686 =head2 DESTROY
2687
2688 This method simply closes the file handle if one is open
2689
2690 =cut
2691 sub DESTROY
2692 {
2693 my $self = shift;
2694
2695 if ( $self->_logopen )
2696 {
2697 close $self->{fh};
2698 }
2699 }
2700
2701 package GITCVS::updater;
2702
2703 ####
2704 #### Copyright The Open University UK - 2006.
2705 ####
2706 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2707 #### Martin Langhoff <martin@catalyst.net.nz>
2708 ####
2709 ####
2710
2711 use strict;
2712 use warnings;
2713 use DBI;
2714
2715 =head1 METHODS
2716
2717 =cut
2718
2719 =head2 new
2720
2721 =cut
2722 sub new
2723 {
2724 my $class = shift;
2725 my $config = shift;
2726 my $module = shift;
2727 my $log = shift;
2728
2729 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2730 die "Need to specify a module" unless ( defined($module) );
2731
2732 $class = ref($class) || $class;
2733
2734 my $self = {};
2735
2736 bless $self, $class;
2737
2738 $self->{valid_tables} = {'revision' => 1,
2739 'revision_ix1' => 1,
2740 'revision_ix2' => 1,
2741 'head' => 1,
2742 'head_ix1' => 1,
2743 'properties' => 1,
2744 'commitmsgs' => 1};
2745
2746 $self->{module} = $module;
2747 $self->{git_path} = $config . "/";
2748
2749 $self->{log} = $log;
2750
2751 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2752
2753 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2754 $cfg->{gitcvs}{dbdriver} || "SQLite";
2755 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2756 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2757 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2758 $cfg->{gitcvs}{dbuser} || "";
2759 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2760 $cfg->{gitcvs}{dbpass} || "";
2761 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2762 $cfg->{gitcvs}{dbtablenameprefix} || "";
2763 my %mapping = ( m => $module,
2764 a => $state->{method},
2765 u => getlogin || getpwuid($<) || $<,
2766 G => $self->{git_path},
2767 g => mangle_dirname($self->{git_path}),
2768 );
2769 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2770 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2771 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2772 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2773
2774 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2775 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2776 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2777 $self->{dbuser},
2778 $self->{dbpass});
2779 die "Error connecting to database\n" unless defined $self->{dbh};
2780
2781 $self->{tables} = {};
2782 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2783 {
2784 $self->{tables}{$table} = 1;
2785 }
2786
2787 # Construct the revision table if required
2788 unless ( $self->{tables}{$self->tablename("revision")} )
2789 {
2790 my $tablename = $self->tablename("revision");
2791 my $ix1name = $self->tablename("revision_ix1");
2792 my $ix2name = $self->tablename("revision_ix2");
2793 $self->{dbh}->do("
2794 CREATE TABLE $tablename (
2795 name TEXT NOT NULL,
2796 revision INTEGER NOT NULL,
2797 filehash TEXT NOT NULL,
2798 commithash TEXT NOT NULL,
2799 author TEXT NOT NULL,
2800 modified TEXT NOT NULL,
2801 mode TEXT NOT NULL
2802 )
2803 ");
2804 $self->{dbh}->do("
2805 CREATE INDEX $ix1name
2806 ON $tablename (name,revision)
2807 ");
2808 $self->{dbh}->do("
2809 CREATE INDEX $ix2name
2810 ON $tablename (name,commithash)
2811 ");
2812 }
2813
2814 # Construct the head table if required
2815 unless ( $self->{tables}{$self->tablename("head")} )
2816 {
2817 my $tablename = $self->tablename("head");
2818 my $ix1name = $self->tablename("head_ix1");
2819 $self->{dbh}->do("
2820 CREATE TABLE $tablename (
2821 name TEXT NOT NULL,
2822 revision INTEGER NOT NULL,
2823 filehash TEXT NOT NULL,
2824 commithash TEXT NOT NULL,
2825 author TEXT NOT NULL,
2826 modified TEXT NOT NULL,
2827 mode TEXT NOT NULL
2828 )
2829 ");
2830 $self->{dbh}->do("
2831 CREATE INDEX $ix1name
2832 ON $tablename (name)
2833 ");
2834 }
2835
2836 # Construct the properties table if required
2837 unless ( $self->{tables}{$self->tablename("properties")} )
2838 {
2839 my $tablename = $self->tablename("properties");
2840 $self->{dbh}->do("
2841 CREATE TABLE $tablename (
2842 key TEXT NOT NULL PRIMARY KEY,
2843 value TEXT
2844 )
2845 ");
2846 }
2847
2848 # Construct the commitmsgs table if required
2849 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2850 {
2851 my $tablename = $self->tablename("commitmsgs");
2852 $self->{dbh}->do("
2853 CREATE TABLE $tablename (
2854 key TEXT NOT NULL PRIMARY KEY,
2855 value TEXT
2856 )
2857 ");
2858 }
2859
2860 return $self;
2861 }
2862
2863 =head2 tablename
2864
2865 =cut
2866 sub tablename
2867 {
2868 my $self = shift;
2869 my $name = shift;
2870
2871 if (exists $self->{valid_tables}{$name}) {
2872 return $self->{dbtablenameprefix} . $name;
2873 } else {
2874 return undef;
2875 }
2876 }
2877
2878 =head2 update
2879
2880 =cut
2881 sub update
2882 {
2883 my $self = shift;
2884
2885 # first lets get the commit list
2886 $ENV{GIT_DIR} = $self->{git_path};
2887
2888 my $commitsha1 = `git rev-parse $self->{module}`;
2889 chomp $commitsha1;
2890
2891 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2892 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2893 {
2894 die("Invalid module '$self->{module}'");
2895 }
2896
2897
2898 my $git_log;
2899 my $lastcommit = $self->_get_prop("last_commit");
2900
2901 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2902 return 1;
2903 }
2904
2905 # Start exclusive lock here...
2906 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2907
2908 # TODO: log processing is memory bound
2909 # if we can parse into a 2nd file that is in reverse order
2910 # we can probably do something really efficient
2911 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2912
2913 if (defined $lastcommit) {
2914 push @git_log_params, "$lastcommit..$self->{module}";
2915 } else {
2916 push @git_log_params, $self->{module};
2917 }
2918 # git-rev-list is the backend / plumbing version of git-log
2919 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2920
2921 my @commits;
2922
2923 my %commit = ();
2924
2925 while ( <GITLOG> )
2926 {
2927 chomp;
2928 if (m/^commit\s+(.*)$/) {
2929 # on ^commit lines put the just seen commit in the stack
2930 # and prime things for the next one
2931 if (keys %commit) {
2932 my %copy = %commit;
2933 unshift @commits, \%copy;
2934 %commit = ();
2935 }
2936 my @parents = split(m/\s+/, $1);
2937 $commit{hash} = shift @parents;
2938 $commit{parents} = \@parents;
2939 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2940 # on rfc822-like lines seen before we see any message,
2941 # lowercase the entry and put it in the hash as key-value
2942 $commit{lc($1)} = $2;
2943 } else {
2944 # message lines - skip initial empty line
2945 # and trim whitespace
2946 if (!exists($commit{message}) && m/^\s*$/) {
2947 # define it to mark the end of headers
2948 $commit{message} = '';
2949 next;
2950 }
2951 s/^\s+//; s/\s+$//; # trim ws
2952 $commit{message} .= $_ . "\n";
2953 }
2954 }
2955 close GITLOG;
2956
2957 unshift @commits, \%commit if ( keys %commit );
2958
2959 # Now all the commits are in the @commits bucket
2960 # ordered by time DESC. for each commit that needs processing,
2961 # determine whether it's following the last head we've seen or if
2962 # it's on its own branch, grab a file list, and add whatever's changed
2963 # NOTE: $lastcommit refers to the last commit from previous run
2964 # $lastpicked is the last commit we picked in this run
2965 my $lastpicked;
2966 my $head = {};
2967 if (defined $lastcommit) {
2968 $lastpicked = $lastcommit;
2969 }
2970
2971 my $committotal = scalar(@commits);
2972 my $commitcount = 0;
2973
2974 # Load the head table into $head (for cached lookups during the update process)
2975 foreach my $file ( @{$self->gethead()} )
2976 {
2977 $head->{$file->{name}} = $file;
2978 }
2979
2980 foreach my $commit ( @commits )
2981 {
2982 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2983 if (defined $lastpicked)
2984 {
2985 if (!in_array($lastpicked, @{$commit->{parents}}))
2986 {
2987 # skip, we'll see this delta
2988 # as part of a merge later
2989 # warn "skipping off-track $commit->{hash}\n";
2990 next;
2991 } elsif (@{$commit->{parents}} > 1) {
2992 # it is a merge commit, for each parent that is
2993 # not $lastpicked, see if we can get a log
2994 # from the merge-base to that parent to put it
2995 # in the message as a merge summary.
2996 my @parents = @{$commit->{parents}};
2997 foreach my $parent (@parents) {
2998 # git-merge-base can potentially (but rarely) throw
2999 # several candidate merge bases. let's assume
3000 # that the first one is the best one.
3001 if ($parent eq $lastpicked) {
3002 next;
3003 }
3004 my $base = eval {
3005 safe_pipe_capture('git-merge-base',
3006 $lastpicked, $parent);
3007 };
3008 # The two branches may not be related at all,
3009 # in which case merge base simply fails to find
3010 # any, but that's Ok.
3011 next if ($@);
3012
3013 chomp $base;
3014 if ($base) {
3015 my @merged;
3016 # print "want to log between $base $parent \n";
3017 open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3018 or die "Cannot call git-log: $!";
3019 my $mergedhash;
3020 while (<GITLOG>) {
3021 chomp;
3022 if (!defined $mergedhash) {
3023 if (m/^commit\s+(.+)$/) {
3024 $mergedhash = $1;
3025 } else {
3026 next;
3027 }
3028 } else {
3029 # grab the first line that looks non-rfc822
3030 # aka has content after leading space
3031 if (m/^\s+(\S.*)$/) {
3032 my $title = $1;
3033 $title = substr($title,0,100); # truncate
3034 unshift @merged, "$mergedhash $title";
3035 undef $mergedhash;
3036 }
3037 }
3038 }
3039 close GITLOG;
3040 if (@merged) {
3041 $commit->{mergemsg} = $commit->{message};
3042 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3043 foreach my $summary (@merged) {
3044 $commit->{mergemsg} .= "\t$summary\n";
3045 }
3046 $commit->{mergemsg} .= "\n\n";
3047 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3048 }
3049 }
3050 }
3051 }
3052 }
3053
3054 # convert the date to CVS-happy format
3055 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3056
3057 if ( defined ( $lastpicked ) )
3058 {
3059 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3060 local ($/) = "\0";
3061 while ( <FILELIST> )
3062 {
3063 chomp;
3064 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3065 {
3066 die("Couldn't process git-diff-tree line : $_");
3067 }
3068 my ($mode, $hash, $change) = ($1, $2, $3);
3069 my $name = <FILELIST>;
3070 chomp($name);
3071
3072 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3073
3074 my $git_perms = "";
3075 $git_perms .= "r" if ( $mode & 4 );
3076 $git_perms .= "w" if ( $mode & 2 );
3077 $git_perms .= "x" if ( $mode & 1 );
3078 $git_perms = "rw" if ( $git_perms eq "" );
3079
3080 if ( $change eq "D" )
3081 {
3082 #$log->debug("DELETE $name");
3083 $head->{$name} = {
3084 name => $name,
3085 revision => $head->{$name}{revision} + 1,
3086 filehash => "deleted",
3087 commithash => $commit->{hash},
3088 modified => $commit->{date},
3089 author => $commit->{author},
3090 mode => $git_perms,
3091 };
3092 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3093 }
3094 elsif ( $change eq "M" || $change eq "T" )
3095 {
3096 #$log->debug("MODIFIED $name");
3097 $head->{$name} = {
3098 name => $name,
3099 revision => $head->{$name}{revision} + 1,
3100 filehash => $hash,
3101 commithash => $commit->{hash},
3102 modified => $commit->{date},
3103 author => $commit->{author},
3104 mode => $git_perms,
3105 };
3106 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3107 }
3108 elsif ( $change eq "A" )
3109 {
3110 #$log->debug("ADDED $name");
3111 $head->{$name} = {
3112 name => $name,
3113 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3114 filehash => $hash,
3115 commithash => $commit->{hash},
3116 modified => $commit->{date},
3117 author => $commit->{author},
3118 mode => $git_perms,
3119 };
3120 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3121 }
3122 else
3123 {
3124 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3125 die;
3126 }
3127 }
3128 close FILELIST;
3129 } else {
3130 # this is used to detect files removed from the repo
3131 my $seen_files = {};
3132
3133 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3134 local $/ = "\0";
3135 while ( <FILELIST> )
3136 {
3137 chomp;
3138 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3139 {
3140 die("Couldn't process git-ls-tree line : $_");
3141 }
3142
3143 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3144
3145 $seen_files->{$git_filename} = 1;
3146
3147 my ( $oldhash, $oldrevision, $oldmode ) = (
3148 $head->{$git_filename}{filehash},
3149 $head->{$git_filename}{revision},
3150 $head->{$git_filename}{mode}
3151 );
3152
3153 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3154 {
3155 $git_perms = "";
3156 $git_perms .= "r" if ( $1 & 4 );
3157 $git_perms .= "w" if ( $1 & 2 );
3158 $git_perms .= "x" if ( $1 & 1 );
3159 } else {
3160 $git_perms = "rw";
3161 }
3162
3163 # unless the file exists with the same hash, we need to update it ...
3164 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3165 {
3166 my $newrevision = ( $oldrevision or 0 ) + 1;
3167
3168 $head->{$git_filename} = {
3169 name => $git_filename,
3170 revision => $newrevision,
3171 filehash => $git_hash,
3172 commithash => $commit->{hash},
3173 modified => $commit->{date},
3174 author => $commit->{author},
3175 mode => $git_perms,
3176 };
3177
3178
3179 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3180 }
3181 }
3182 close FILELIST;
3183
3184 # Detect deleted files
3185 foreach my $file ( keys %$head )
3186 {
3187 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3188 {
3189 $head->{$file}{revision}++;
3190 $head->{$file}{filehash} = "deleted";
3191 $head->{$file}{commithash} = $commit->{hash};
3192 $head->{$file}{modified} = $commit->{date};
3193 $head->{$file}{author} = $commit->{author};
3194
3195 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3196 }
3197 }
3198 # END : "Detect deleted files"
3199 }
3200
3201
3202 if (exists $commit->{mergemsg})
3203 {
3204 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3205 }
3206
3207 $lastpicked = $commit->{hash};
3208
3209 $self->_set_prop("last_commit", $commit->{hash});
3210 }
3211
3212 $self->delete_head();
3213 foreach my $file ( keys %$head )
3214 {
3215 $self->insert_head(
3216 $file,
3217 $head->{$file}{revision},
3218 $head->{$file}{filehash},
3219 $head->{$file}{commithash},
3220 $head->{$file}{modified},
3221 $head->{$file}{author},
3222 $head->{$file}{mode},
3223 );
3224 }
3225 # invalidate the gethead cache
3226 $self->{gethead_cache} = undef;
3227
3228
3229 # Ending exclusive lock here
3230 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3231 }
3232
3233 sub insert_rev
3234 {
3235 my $self = shift;
3236 my $name = shift;
3237 my $revision = shift;
3238 my $filehash = shift;
3239 my $commithash = shift;
3240 my $modified = shift;
3241 my $author = shift;
3242 my $mode = shift;
3243 my $tablename = $self->tablename("revision");
3244
3245 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3246 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3247 }
3248
3249 sub insert_mergelog
3250 {
3251 my $self = shift;
3252 my $key = shift;
3253 my $value = shift;
3254 my $tablename = $self->tablename("commitmsgs");
3255
3256 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3257 $insert_mergelog->execute($key, $value);
3258 }
3259
3260 sub delete_head
3261 {
3262 my $self = shift;
3263 my $tablename = $self->tablename("head");
3264
3265 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3266 $delete_head->execute();
3267 }
3268
3269 sub insert_head
3270 {
3271 my $self = shift;
3272 my $name = shift;
3273 my $revision = shift;
3274 my $filehash = shift;
3275 my $commithash = shift;
3276 my $modified = shift;
3277 my $author = shift;
3278 my $mode = shift;
3279 my $tablename = $self->tablename("head");
3280
3281 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3282 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3283 }
3284
3285 sub _headrev
3286 {
3287 my $self = shift;
3288 my $filename = shift;
3289 my $tablename = $self->tablename("head");
3290
3291 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3292 $db_query->execute($filename);
3293 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3294
3295 return ( $hash, $revision, $mode );
3296 }
3297
3298 sub _get_prop
3299 {
3300 my $self = shift;
3301 my $key = shift;
3302 my $tablename = $self->tablename("properties");
3303
3304 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3305 $db_query->execute($key);
3306 my ( $value ) = $db_query->fetchrow_array;
3307
3308 return $value;
3309 }
3310
3311 sub _set_prop
3312 {
3313 my $self = shift;
3314 my $key = shift;
3315 my $value = shift;
3316 my $tablename = $self->tablename("properties");
3317
3318 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3319 $db_query->execute($value, $key);
3320
3321 unless ( $db_query->rows )
3322 {
3323 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3324 $db_query->execute($key, $value);
3325 }
3326
3327 return $value;
3328 }
3329
3330 =head2 gethead
3331
3332 =cut
3333
3334 sub gethead
3335 {
3336 my $self = shift;
3337 my $tablename = $self->tablename("head");
3338
3339 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3340
3341 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3342 $db_query->execute();
3343
3344 my $tree = [];
3345 while ( my $file = $db_query->fetchrow_hashref )
3346 {
3347 push @$tree, $file;
3348 }
3349
3350 $self->{gethead_cache} = $tree;
3351
3352 return $tree;
3353 }
3354
3355 =head2 getlog
3356
3357 =cut
3358
3359 sub getlog
3360 {
3361 my $self = shift;
3362 my $filename = shift;
3363 my $tablename = $self->tablename("revision");
3364
3365 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3366 $db_query->execute($filename);
3367
3368 my $tree = [];
3369 while ( my $file = $db_query->fetchrow_hashref )
3370 {
3371 push @$tree, $file;
3372 }
3373
3374 return $tree;
3375 }
3376
3377 =head2 getmeta
3378
3379 This function takes a filename (with path) argument and returns a hashref of
3380 metadata for that file.
3381
3382 =cut
3383
3384 sub getmeta
3385 {
3386 my $self = shift;
3387 my $filename = shift;
3388 my $revision = shift;
3389 my $tablename_rev = $self->tablename("revision");
3390 my $tablename_head = $self->tablename("head");
3391
3392 my $db_query;
3393 if ( defined($revision) and $revision =~ /^\d+$/ )
3394 {
3395 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3396 $db_query->execute($filename, $revision);
3397 }
3398 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3399 {
3400 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3401 $db_query->execute($filename, $revision);
3402 } else {
3403 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3404 $db_query->execute($filename);
3405 }
3406
3407 return $db_query->fetchrow_hashref;
3408 }
3409
3410 =head2 commitmessage
3411
3412 this function takes a commithash and returns the commit message for that commit
3413
3414 =cut
3415 sub commitmessage
3416 {
3417 my $self = shift;
3418 my $commithash = shift;
3419 my $tablename = $self->tablename("commitmsgs");
3420
3421 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3422
3423 my $db_query;
3424 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3425 $db_query->execute($commithash);
3426
3427 my ( $message ) = $db_query->fetchrow_array;
3428
3429 if ( defined ( $message ) )
3430 {
3431 $message .= " " if ( $message =~ /\n$/ );
3432 return $message;
3433 }
3434
3435 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3436 shift @lines while ( $lines[0] =~ /\S/ );
3437 $message = join("",@lines);
3438 $message .= " " if ( $message =~ /\n$/ );
3439 return $message;
3440 }
3441
3442 =head2 gethistory
3443
3444 This function takes a filename (with path) argument and returns an arrayofarrays
3445 containing revision,filehash,commithash ordered by revision descending
3446
3447 =cut
3448 sub gethistory
3449 {
3450 my $self = shift;
3451 my $filename = shift;
3452 my $tablename = $self->tablename("revision");
3453
3454 my $db_query;
3455 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3456 $db_query<