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