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