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