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