]> git.ipfire.org Git - thirdparty/git.git/blame - git-cvsserver.perl
test-ref-store: remove force-create argument for create-reflog
[thirdparty/git.git] / git-cvsserver.perl
CommitLineData
3fda8c4c
ML
1#!/usr/bin/perl
2
3####
4#### This application is a CVS emulation layer for git.
5#### It is intended for clients to connect over SSH.
6#### See the documentation for more details.
7####
8#### Copyright The Open University UK - 2006.
9####
10#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 11#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
12####
13####
14#### Released under the GNU Public License, version 2.
15####
16####
17
d48b2841 18use 5.008;
3fda8c4c
ML
19use strict;
20use warnings;
4f88d3e0 21use bytes;
3fda8c4c
ML
22
23use Fcntl;
24use File::Temp qw/tempdir tempfile/;
044182ef 25use File::Path qw/rmtree/;
3fda8c4c 26use File::Basename;
693b6327
FL
27use Getopt::Long qw(:config require_order no_ignore_case);
28
29my $VERSION = '@@GIT_VERSION@@';
3fda8c4c
ML
30
31my $log = GITCVS::log->new();
32my $cfg;
33
34my $DATE_LIST = {
35 Jan => "01",
36 Feb => "02",
37 Mar => "03",
38 Apr => "04",
39 May => "05",
40 Jun => "06",
41 Jul => "07",
42 Aug => "08",
43 Sep => "09",
44 Oct => "10",
45 Nov => "11",
46 Dec => "12",
47};
48
49# Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50$| = 1;
51
52#### Definition and mappings of functions ####
53
566c69e7
MO
54# NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
55# requests, this list is incomplete. It is missing many rarer/optional
56# requests. Perhaps some clients require a claim of support for
57# these specific requests for main functionality to work?
3fda8c4c
ML
58my $methods = {
59 'Root' => \&req_Root,
60 'Valid-responses' => \&req_Validresponses,
61 'valid-requests' => \&req_validrequests,
62 'Directory' => \&req_Directory,
eb5dcb2c 63 'Sticky' => \&req_Sticky,
3fda8c4c
ML
64 'Entry' => \&req_Entry,
65 'Modified' => \&req_Modified,
66 'Unchanged' => \&req_Unchanged,
7172aabb 67 'Questionable' => \&req_Questionable,
3fda8c4c
ML
68 'Argument' => \&req_Argument,
69 'Argumentx' => \&req_Argument,
70 'expand-modules' => \&req_expandmodules,
71 'add' => \&req_add,
72 'remove' => \&req_remove,
73 'co' => \&req_co,
74 'update' => \&req_update,
75 'ci' => \&req_ci,
76 'diff' => \&req_diff,
77 'log' => \&req_log,
7172aabb 78 'rlog' => \&req_log,
3fda8c4c
ML
79 'tag' => \&req_CATCHALL,
80 'status' => \&req_status,
81 'admin' => \&req_CATCHALL,
82 'history' => \&req_CATCHALL,
38bcd31a
DD
83 'watchers' => \&req_EMPTY,
84 'editors' => \&req_EMPTY,
499cc56a 85 'noop' => \&req_EMPTY,
3fda8c4c
ML
86 'annotate' => \&req_annotate,
87 'Global_option' => \&req_Globaloption,
3fda8c4c
ML
88};
89
90##############################################
91
92
93# $state holds all the bits of information the clients sends us that could
94# potentially be useful when it comes to actually _doing_ something.
42217f13 95my $state = { prependdir => '' };
044182ef
MO
96
97# Work is for managing temporary working directory
98my $work =
99 {
100 state => undef, # undef, 1 (empty), 2 (with stuff)
101 workDir => undef,
102 index => undef,
103 emptyDir => undef,
104 tmpDir => undef
105 };
106
3fda8c4c
ML
107$log->info("--------------- STARTING -----------------");
108
693b6327 109my $usage =
d2bb624c 110 "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
693b6327 111 " --base-path <path> : Prepend to requested CVSROOT\n".
03bd0d60 112 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
693b6327
FL
113 " --strict-paths : Don't allow recursing into subdirectories\n".
114 " --export-all : Don't check for gitcvs.enabled in config\n".
115 " --version, -V : Print version information and exit\n".
87182b17 116 " -h, -H : Print usage information and exit\n".
693b6327
FL
117 "\n".
118 "<directory> ... is a list of allowed directories. If no directories\n".
119 "are given, all are allowed. This is an additional restriction, gitcvs\n".
03bd0d60
PM
120 "access still needs to be enabled by the gitcvs.enabled config option.\n".
121 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
693b6327 122
87182b17 123my @opts = ( 'h|H', 'version|V',
693b6327
FL
124 'base-path=s', 'strict-paths', 'export-all' );
125GetOptions( $state, @opts )
126 or die $usage;
127
128if ($state->{version}) {
129 print "git-cvsserver version $VERSION\n";
130 exit;
131}
132if ($state->{help}) {
133 print $usage;
134 exit;
135}
136
3fda8c4c
ML
137my $TEMP_DIR = tempdir( CLEANUP => 1 );
138$log->debug("Temporary directory is '$TEMP_DIR'");
139
693b6327
FL
140$state->{method} = 'ext';
141if (@ARGV) {
142 if ($ARGV[0] eq 'pserver') {
143 $state->{method} = 'pserver';
144 shift @ARGV;
145 } elsif ($ARGV[0] eq 'server') {
146 shift @ARGV;
147 }
148}
149
150# everything else is a directory
151$state->{allowed_roots} = [ @ARGV ];
152
226bccb9
FL
153# don't export the whole system unless the users requests it
154if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
155 die "--export-all can only be used together with an explicit whitelist\n";
156}
157
03bd0d60
PM
158# Environment handling for running under git-shell
159if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
160 if ($state->{'base-path'}) {
161 die "Cannot specify base path both ways.\n";
162 }
163 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
164 $state->{'base-path'} = $base_path;
165 $log->debug("Picked up base path '$base_path' from environment.\n");
166}
167if (exists $ENV{GIT_CVSSERVER_ROOT}) {
168 if (@{$state->{allowed_roots}}) {
169 die "Cannot specify roots both ways: @ARGV\n";
170 }
171 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
172 $state->{allowed_roots} = [ $allowed_root ];
173 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
174}
175
91a6bf46 176# if we are called with a pserver argument,
5348b6e7 177# deal with the authentication cat before entering the
91a6bf46 178# main loop
693b6327 179if ($state->{method} eq 'pserver') {
91a6bf46 180 my $line = <STDIN>; chomp $line;
24a97d84 181 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
91a6bf46
ML
182 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
183 }
24a97d84 184 my $request = $1;
91a6bf46 185 $line = <STDIN>; chomp $line;
2a4b5d5a
BG
186 unless (req_Root('root', $line)) { # reuse Root
187 print "E Invalid root $line \n";
188 exit 1;
189 }
91a6bf46 190 $line = <STDIN>; chomp $line;
031a027a
ÆAB
191 my $user = $line;
192 $line = <STDIN>; chomp $line;
193 my $password = $line;
194
475357a3
ÆAB
195 if ($user eq 'anonymous') {
196 # "A" will be 1 byte, use length instead in case the
197 # encryption method ever changes (yeah, right!)
198 if (length($password) > 1 ) {
199 print "E Don't supply a password for the `anonymous' user\n";
200 print "I HATE YOU\n";
201 exit 1;
202 }
203
204 # Fall through to LOVE
205 } else {
031a027a 206 # Trying to authenticate a user
c057bad3 207 if (not exists $cfg->{gitcvs}->{authdb}) {
475357a3
ÆAB
208 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
209 print "I HATE YOU\n";
210 exit 1;
211 }
212
213 my $authdb = $cfg->{gitcvs}->{authdb};
214
215 unless (-e $authdb) {
216 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
031a027a
ÆAB
217 print "I HATE YOU\n";
218 exit 1;
c057bad3 219 }
3052525e
ÆAB
220
221 my $auth_ok;
475357a3 222 open my $passwd, "<", $authdb or die $!;
3052525e
ÆAB
223 while (<$passwd>) {
224 if (m{^\Q$user\E:(.*)}) {
bffcb4d9
CMAB
225 my $hash = crypt(descramble($password), $1);
226 if (defined $hash and $hash eq $1) {
3052525e
ÆAB
227 $auth_ok = 1;
228 }
bffcb4d9 229 }
3052525e
ÆAB
230 }
231 close $passwd;
232
233 unless ($auth_ok) {
031a027a
ÆAB
234 print "I HATE YOU\n";
235 exit 1;
031a027a 236 }
475357a3
ÆAB
237
238 # Fall through to LOVE
91a6bf46 239 }
031a027a
ÆAB
240
241 # For checking whether the user is anonymous on commit
242 $state->{user} = $user;
243
91a6bf46 244 $line = <STDIN>; chomp $line;
24a97d84
FL
245 unless ($line eq "END $request REQUEST") {
246 die "E Do not understand $line -- expecting END $request REQUEST\n";
91a6bf46
ML
247 }
248 print "I LOVE YOU\n";
24a97d84 249 exit if $request eq 'VERIFICATION'; # cvs login
91a6bf46
ML
250 # and now back to our regular programme...
251}
252
3fda8c4c
ML
253# Keep going until the client closes the connection
254while (<STDIN>)
255{
256 chomp;
257
5348b6e7 258 # Check to see if we've seen this method, and call appropriate function.
3fda8c4c
ML
259 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
260 {
261 # use the $methods hash to call the appropriate sub for this command
262 #$log->info("Method : $1");
263 &{$methods->{$1}}($1,$2);
264 } else {
265 # log fatal because we don't understand this function. If this happens
266 # we're fairly screwed because we don't know if the client is expecting
267 # a response. If it is, the client will hang, we'll hang, and the whole
268 # thing will be custard.
269 $log->fatal("Don't understand command $_\n");
270 die("Unknown command $_");
271 }
272}
273
274$log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
275$log->info("--------------- FINISH -----------------");
276
044182ef
MO
277chdir '/';
278exit 0;
279
3fda8c4c
ML
280# Magic catchall method.
281# This is the method that will handle all commands we haven't yet
282# implemented. It simply sends a warning to the log file indicating a
283# command that hasn't been implemented has been invoked.
284sub req_CATCHALL
285{
286 my ( $cmd, $data ) = @_;
287 $log->warn("Unhandled command : req_$cmd : $data");
288}
289
38bcd31a
DD
290# This method invariably succeeds with an empty response.
291sub req_EMPTY
292{
293 print "ok\n";
294}
3fda8c4c
ML
295
296# Root pathname \n
297# Response expected: no. Tell the server which CVSROOT to use. Note that
298# pathname is a local directory and not a fully qualified CVSROOT variable.
299# pathname must already exist; if creating a new root, use the init
300# request, not Root. pathname does not include the hostname of the server,
301# how to access the server, etc.; by the time the CVS protocol is in use,
302# connection, authentication, etc., are already taken care of. The Root
303# request must be sent only once, and it must be sent before any requests
304# other than Valid-responses, valid-requests, UseUnchanged, Set or init.
305sub req_Root
306{
307 my ( $cmd, $data ) = @_;
308 $log->debug("req_Root : $data");
309
4890888d
FL
310 unless ($data =~ m#^/#) {
311 print "error 1 Root must be an absolute pathname\n";
312 return 0;
313 }
314
fd1cd91e
FL
315 my $cvsroot = $state->{'base-path'} || '';
316 $cvsroot =~ s#/+$##;
317 $cvsroot .= $data;
318
4890888d 319 if ($state->{CVSROOT}
fd1cd91e 320 && ($state->{CVSROOT} ne $cvsroot)) {
4890888d
FL
321 print "error 1 Conflicting roots specified\n";
322 return 0;
323 }
324
fd1cd91e 325 $state->{CVSROOT} = $cvsroot;
3fda8c4c
ML
326
327 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
693b6327
FL
328
329 if (@{$state->{allowed_roots}}) {
330 my $allowed = 0;
331 foreach my $dir (@{$state->{allowed_roots}}) {
332 next unless $dir =~ m#^/#;
333 $dir =~ s#/+$##;
334 if ($state->{'strict-paths'}) {
335 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
336 $allowed = 1;
337 last;
338 }
339 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
340 $allowed = 1;
341 last;
342 }
343 }
344
345 unless ($allowed) {
346 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
347 print "E \n";
348 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
349 return 0;
350 }
351 }
352
cdb6760e
ML
353 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
354 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
693b6327
FL
355 print "E \n";
356 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
cdb6760e
ML
357 return 0;
358 }
3fda8c4c 359
46203ac2 360 my @gitvars = safe_pipe_capture(qw(git config -l));
cdb6760e 361 if ($?) {
e0d10e1c 362 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
cdb6760e 363 print "E \n";
e0d10e1c 364 print "error 1 - problem executing git-config\n";
cdb6760e
ML
365 return 0;
366 }
367 foreach my $line ( @gitvars )
3fda8c4c 368 {
05ea93d6 369 next unless ( $line =~ /^(gitcvs|extensions)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
f987afa8
FL
370 unless ($2) {
371 $cfg->{$1}{$3} = $4;
92a39a14
FL
372 } else {
373 $cfg->{$1}{$2}{$3} = $4;
374 }
3fda8c4c
ML
375 }
376
523d12e5
JH
377 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
378 || $cfg->{gitcvs}{enabled});
226bccb9
FL
379 unless ($state->{'export-all'} ||
380 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
3fda8c4c
ML
381 print "E GITCVS emulation needs to be enabled on this repo\n";
382 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
383 print "E \n";
384 print "error 1 GITCVS emulation disabled\n";
91a6bf46 385 return 0;
3fda8c4c
ML
386 }
387
d55820ce
FL
388 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
389 if ( $logfile )
3fda8c4c 390 {
d55820ce 391 $log->setfile($logfile);
3fda8c4c
ML
392 } else {
393 $log->nofile();
394 }
91a6bf46 395
05ea93d6 396 $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20;
397 $state->{hexsz} = $state->{rawsz} * 2;
398
91a6bf46 399 return 1;
3fda8c4c
ML
400}
401
402# Global_option option \n
403# Response expected: no. Transmit one of the global options `-q', `-Q',
404# `-l', `-t', `-r', or `-n'. option must be one of those strings, no
405# variations (such as combining of options) are allowed. For graceful
406# handling of valid-requests, it is probably better to make new global
407# options separate requests, rather than trying to add them to this
408# request.
409sub req_Globaloption
410{
411 my ( $cmd, $data ) = @_;
412 $log->debug("req_Globaloption : $data");
7d90095a 413 $state->{globaloptions}{$data} = 1;
3fda8c4c
ML
414}
415
416# Valid-responses request-list \n
417# Response expected: no. Tell the server what responses the client will
418# accept. request-list is a space separated list of tokens.
419sub req_Validresponses
420{
421 my ( $cmd, $data ) = @_;
5348b6e7 422 $log->debug("req_Validresponses : $data");
3fda8c4c
ML
423
424 # TODO : re-enable this, currently it's not particularly useful
425 #$state->{validresponses} = [ split /\s+/, $data ];
426}
427
428# valid-requests \n
429# Response expected: yes. Ask the server to send back a Valid-requests
430# response.
431sub req_validrequests
432{
433 my ( $cmd, $data ) = @_;
434
435 $log->debug("req_validrequests");
436
9462953a 437 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
3fda8c4c
ML
438 $log->debug("SEND : ok");
439
9462953a 440 print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
3fda8c4c
ML
441 print "ok\n";
442}
443
444# Directory local-directory \n
445# Additional data: repository \n. Response expected: no. Tell the server
446# what directory to use. The repository should be a directory name from a
447# previous server response. Note that this both gives a default for Entry
448# and Modified and also for ci and the other commands; normal usage is to
449# send Directory for each directory in which there will be an Entry or
450# Modified, and then a final Directory for the original directory, then the
451# command. The local-directory is relative to the top level at which the
452# command is occurring (i.e. the last Directory which is sent before the
453# command); to indicate that top level, `.' should be sent for
454# local-directory.
455sub req_Directory
456{
457 my ( $cmd, $data ) = @_;
458
459 my $repository = <STDIN>;
460 chomp $repository;
461
462
463 $state->{localdir} = $data;
464 $state->{repository} = $repository;
7d90095a 465 $state->{path} = $repository;
f9acaeae 466 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
7d90095a
MS
467 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
468 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
469
470 $state->{directory} = $state->{localdir};
471 $state->{directory} = "" if ( $state->{directory} eq "." );
3fda8c4c
ML
472 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
473
d988b822 474 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
7d90095a
MS
475 {
476 $log->info("Setting prepend to '$state->{path}'");
477 $state->{prependdir} = $state->{path};
eb5dcb2c 478 my %entries;
7d90095a
MS
479 foreach my $entry ( keys %{$state->{entries}} )
480 {
eb5dcb2c 481 $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
7d90095a 482 }
eb5dcb2c
MO
483 $state->{entries}=\%entries;
484
485 my %dirMap;
486 foreach my $dir ( keys %{$state->{dirMap}} )
487 {
488 $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
489 }
490 $state->{dirMap}=\%dirMap;
7d90095a
MS
491 }
492
493 if ( defined ( $state->{prependdir} ) )
494 {
495 $log->debug("Prepending '$state->{prependdir}' to state|directory");
496 $state->{directory} = $state->{prependdir} . $state->{directory}
497 }
eb5dcb2c
MO
498
499 if ( ! defined($state->{dirMap}{$state->{directory}}) )
500 {
501 $state->{dirMap}{$state->{directory}} =
502 {
503 'names' => {}
504 #'tagspec' => undef
505 };
506 }
507
82000d74 508 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
3fda8c4c
ML
509}
510
eb5dcb2c
MO
511# Sticky tagspec \n
512# Response expected: no. Tell the server that the directory most
513# recently specified with Directory has a sticky tag or date
514# tagspec. The first character of tagspec is T for a tag, D for
515# a date, or some other character supplied by a Set-sticky
516# response from a previous request to the server. The remainder
517# of tagspec contains the actual tag or date, again as supplied
518# by Set-sticky.
519# The server should remember Static-directory and Sticky requests
520# for a particular directory; the client need not resend them each
521# time it sends a Directory request for a given directory. However,
522# the server is not obliged to remember them beyond the context
523# of a single command.
524sub req_Sticky
525{
526 my ( $cmd, $tagspec ) = @_;
527
528 my ( $stickyInfo );
529 if($tagspec eq "")
530 {
531 # nothing
532 }
533 elsif($tagspec=~/^T([^ ]+)\s*$/)
534 {
535 $stickyInfo = { 'tag' => $1 };
536 }
537 elsif($tagspec=~/^D([0-9.]+)\s*$/)
538 {
539 $stickyInfo= { 'date' => $1 };
540 }
541 else
542 {
543 die "Unknown tag_or_date format\n";
544 }
545 $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
546
547 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
548 . " path=$state->{path} directory=$state->{directory}"
549 . " module=$state->{module}");
550}
551
3fda8c4c
ML
552# Entry entry-line \n
553# Response expected: no. Tell the server what version of a file is on the
554# local machine. The name in entry-line is a name relative to the directory
555# most recently specified with Directory. If the user is operating on only
556# some files in a directory, Entry requests for only those files need be
557# included. If an Entry request is sent without Modified, Is-modified, or
558# Unchanged, it means the file is lost (does not exist in the working
559# directory). If both Entry and one of Modified, Is-modified, or Unchanged
560# are sent for the same file, Entry must be sent first. For a given file,
561# one can send Modified, Is-modified, or Unchanged, but not more than one
562# of these three.
563sub req_Entry
564{
565 my ( $cmd, $data ) = @_;
566
7d90095a 567 #$log->debug("req_Entry : $data");
3fda8c4c 568
abd66f22 569 my @data = split(/\//, $data, -1);
3fda8c4c
ML
570
571 $state->{entries}{$state->{directory}.$data[1]} = {
572 revision => $data[2],
573 conflict => $data[3],
574 options => $data[4],
575 tag_or_date => $data[5],
576 };
7d90095a 577
eb5dcb2c
MO
578 $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
579
7d90095a
MS
580 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
581}
582
583# Questionable filename \n
584# Response expected: no. Additional data: no. Tell the server to check
585# whether filename should be ignored, and if not, next time the server
586# sends responses, send (in a M response) `?' followed by the directory and
587# filename. filename must not contain `/'; it needs to be a file in the
588# directory named by the most recent Directory request.
589sub req_Questionable
590{
591 my ( $cmd, $data ) = @_;
592
593 $log->debug("req_Questionable : $data");
594 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
3fda8c4c
ML
595}
596
597# add \n
598# Response expected: yes. Add a file or directory. This uses any previous
599# Argument, Directory, Entry, or Modified requests, if they have been sent.
600# The last Directory sent specifies the working directory at the time of
601# the operation. To add a directory, send the directory to be added using
602# Directory and Argument requests.
603sub req_add
604{
605 my ( $cmd, $data ) = @_;
606
607 argsplit("add");
608
4db0c8de
FL
609 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
610 $updater->update();
611
3fda8c4c
ML
612 my $addcount = 0;
613
614 foreach my $filename ( @{$state->{args}} )
615 {
616 $filename = filecleanup($filename);
617
61717661
MO
618 # no -r, -A, or -D with add
619 my $stickyInfo = resolveStickyInfo($filename);
620
621 my $meta = $updater->getmeta($filename,$stickyInfo);
4db0c8de
FL
622 my $wrev = revparse($filename);
623
ab07681f 624 if ($wrev && $meta && ($wrev=~/^-/))
4db0c8de
FL
625 {
626 # previously removed file, add back
ab07681f 627 $log->info("added file $filename was previously removed, send $meta->{revision}");
4db0c8de
FL
628
629 print "MT +updated\n";
630 print "MT text U \n";
631 print "MT fname $filename\n";
632 print "MT newline\n";
633 print "MT -updated\n";
634
635 unless ( $state->{globaloptions}{-n} )
636 {
637 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
638
639 print "Created $dirpart\n";
640 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
641
642 # this is an "entries" line
90948a42 643 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
644 my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
645 $entryLine .= getStickyTagOrDate($stickyInfo);
646 $log->debug($entryLine);
647 print "$entryLine\n";
4db0c8de
FL
648 # permissions
649 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
650 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
651 # transmit file
652 transmitfile($meta->{filehash});
653 }
654
655 next;
656 }
657
3fda8c4c
ML
658 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
659 {
660 print "E cvs add: nothing known about `$filename'\n";
661 next;
662 }
663 # TODO : check we're not squashing an already existing file
664 if ( defined ( $state->{entries}{$filename}{revision} ) )
665 {
666 print "E cvs add: `$filename' has already been entered\n";
667 next;
668 }
669
7d90095a 670 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
671
672 print "E cvs add: scheduling file `$filename' for addition\n";
673
674 print "Checked-in $dirpart\n";
675 print "$filename\n";
90948a42
MO
676 my $kopts = kopts_from_path($filename,"file",
677 $state->{entries}{$filename}{modified_filename});
61717661
MO
678 print "/$filepart/0//$kopts/" .
679 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c 680
8a06a632
MO
681 my $requestedKopts = $state->{opt}{k};
682 if(defined($requestedKopts))
683 {
684 $requestedKopts = "-k$requestedKopts";
685 }
686 else
687 {
688 $requestedKopts = "";
689 }
690 if( $kopts ne $requestedKopts )
691 {
692 $log->warn("Ignoring requested -k='$requestedKopts'"
693 . " for '$filename'; detected -k='$kopts' instead");
694 #TODO: Also have option to send warning to user?
695 }
696
3fda8c4c
ML
697 $addcount++;
698 }
699
700 if ( $addcount == 1 )
701 {
702 print "E cvs add: use `cvs commit' to add this file permanently\n";
703 }
704 elsif ( $addcount > 1 )
705 {
706 print "E cvs add: use `cvs commit' to add these files permanently\n";
707 }
708
709 print "ok\n";
710}
711
712# remove \n
713# Response expected: yes. Remove a file. This uses any previous Argument,
714# Directory, Entry, or Modified requests, if they have been sent. The last
715# Directory sent specifies the working directory at the time of the
716# operation. Note that this request does not actually do anything to the
717# repository; the only effect of a successful remove request is to supply
718# the client with a new entries line containing `-' to indicate a removed
719# file. In fact, the client probably could perform this operation without
720# contacting the server, although using remove may cause the server to
721# perform a few more checks. The client sends a subsequent ci request to
722# actually record the removal in the repository.
723sub req_remove
724{
725 my ( $cmd, $data ) = @_;
726
727 argsplit("remove");
728
729 # Grab a handle to the SQLite db and do any necessary updates
730 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
731 $updater->update();
732
733 #$log->debug("add state : " . Dumper($state));
734
735 my $rmcount = 0;
736
737 foreach my $filename ( @{$state->{args}} )
738 {
739 $filename = filecleanup($filename);
740
741 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
742 {
743 print "E cvs remove: file `$filename' still in working directory\n";
744 next;
745 }
746
61717661
MO
747 # only from entries
748 my $stickyInfo = resolveStickyInfo($filename);
749
750 my $meta = $updater->getmeta($filename,$stickyInfo);
3fda8c4c
ML
751 my $wrev = revparse($filename);
752
753 unless ( defined ( $wrev ) )
754 {
755 print "E cvs remove: nothing known about `$filename'\n";
756 next;
757 }
758
ab07681f 759 if ( defined($wrev) and ($wrev=~/^-/) )
3fda8c4c
ML
760 {
761 print "E cvs remove: file `$filename' already scheduled for removal\n";
762 next;
763 }
764
ab07681f 765 unless ( $wrev eq $meta->{revision} )
3fda8c4c
ML
766 {
767 # TODO : not sure if the format of this message is quite correct.
768 print "E cvs remove: Up to date check failed for `$filename'\n";
769 next;
770 }
771
772
7d90095a 773 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
774
775 print "E cvs remove: scheduling `$filename' for removal\n";
776
777 print "Checked-in $dirpart\n";
778 print "$filename\n";
90948a42 779 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661 780 print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
781
782 $rmcount++;
783 }
784
785 if ( $rmcount == 1 )
786 {
787 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
788 }
789 elsif ( $rmcount > 1 )
790 {
791 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
792 }
793
794 print "ok\n";
795}
796
797# Modified filename \n
798# Response expected: no. Additional data: mode, \n, file transmission. Send
799# the server a copy of one locally modified file. filename is a file within
800# the most recent directory sent with Directory; it must not contain `/'.
801# If the user is operating on only some files in a directory, only those
802# files need to be included. This can also be sent without Entry, if there
803# is no entry for the file.
804sub req_Modified
805{
806 my ( $cmd, $data ) = @_;
807
808 my $mode = <STDIN>;
a5e40798
JM
809 defined $mode
810 or (print "E end of file reading mode for $data\n"), return;
3fda8c4c
ML
811 chomp $mode;
812 my $size = <STDIN>;
a5e40798
JM
813 defined $size
814 or (print "E end of file reading size of $data\n"), return;
3fda8c4c
ML
815 chomp $size;
816
817 # Grab config information
818 my $blocksize = 8192;
819 my $bytesleft = $size;
820 my $tmp;
821
822 # Get a filehandle/name to write it to
823 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
824
825 # Loop over file data writing out to temporary file.
826 while ( $bytesleft )
827 {
828 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
829 read STDIN, $tmp, $blocksize;
830 print $fh $tmp;
831 $bytesleft -= $blocksize;
832 }
833
a5e40798
JM
834 close $fh
835 or (print "E failed to write temporary, $filename: $!\n"), return;
3fda8c4c
ML
836
837 # Ensure we have something sensible for the file mode
838 if ( $mode =~ /u=(\w+)/ )
839 {
840 $mode = $1;
841 } else {
842 $mode = "rw";
843 }
844
845 # Save the file data in $state
846 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
847 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
27dd7387 848 $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename);
3fda8c4c
ML
849 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
850
851 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
852}
853
854# Unchanged filename \n
855# Response expected: no. Tell the server that filename has not been
856# modified in the checked out directory. The filename is a file within the
857# most recent directory sent with Directory; it must not contain `/'.
858sub req_Unchanged
859{
860 my ( $cmd, $data ) = @_;
861
862 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
863
864 #$log->debug("req_Unchanged : $data");
865}
866
867# Argument text \n
868# Response expected: no. Save argument for use in a subsequent command.
869# Arguments accumulate until an argument-using command is given, at which
870# point they are forgotten.
871# Argumentx text \n
872# Response expected: no. Append \n followed by text to the current argument
873# being saved.
874sub req_Argument
875{
876 my ( $cmd, $data ) = @_;
877
2c3cff49 878 # Argumentx means: append to last Argument (with a newline in front)
3fda8c4c
ML
879
880 $log->debug("$cmd : $data");
881
2c3cff49
JS
882 if ( $cmd eq 'Argumentx') {
883 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
884 } else {
885 push @{$state->{arguments}}, $data;
886 }
3fda8c4c
ML
887}
888
889# expand-modules \n
890# Response expected: yes. Expand the modules which are specified in the
891# arguments. Returns the data in Module-expansion responses. Note that the
892# server can assume that this is checkout or export, not rtag or rdiff; the
893# latter do not access the working directory and thus have no need to
894# expand modules on the client side. Expand may not be the best word for
895# what this request does. It does not necessarily tell you all the files
896# contained in a module, for example. Basically it is a way of telling you
897# which working directories the server needs to know about in order to
898# handle a checkout of the specified modules. For example, suppose that the
899# server has a module defined by
900# aliasmodule -a 1dir
901# That is, one can check out aliasmodule and it will take 1dir in the
902# repository and check it out to 1dir in the working directory. Now suppose
903# the client already has this module checked out and is planning on using
904# the co request to update it. Without using expand-modules, the client
905# would have two bad choices: it could either send information about all
906# working directories under the current directory, which could be
907# unnecessarily slow, or it could be ignorant of the fact that aliasmodule
908# stands for 1dir, and neglect to send information for 1dir, which would
909# lead to incorrect operation. With expand-modules, the client would first
910# ask for the module to be expanded:
911sub req_expandmodules
912{
913 my ( $cmd, $data ) = @_;
914
915 argsplit();
916
917 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
918
919 unless ( ref $state->{arguments} eq "ARRAY" )
920 {
921 print "ok\n";
922 return;
923 }
924
925 foreach my $module ( @{$state->{arguments}} )
926 {
927 $log->debug("SEND : Module-expansion $module");
928 print "Module-expansion $module\n";
929 }
930
931 print "ok\n";
932 statecleanup();
933}
934
935# co \n
936# Response expected: yes. Get files from the repository. This uses any
937# previous Argument, Directory, Entry, or Modified requests, if they have
938# been sent. Arguments to this command are module names; the client cannot
939# know what directories they correspond to except by (1) just sending the
940# co request, and then seeing what directory names the server sends back in
941# its responses, and (2) the expand-modules request.
942sub req_co
943{
944 my ( $cmd, $data ) = @_;
945
946 argsplit("co");
947
89a9167f
LN
948 # Provide list of modules, if -c was used.
949 if (exists $state->{opt}{c}) {
46203ac2 950 my $showref = safe_pipe_capture(qw(git show-ref --heads));
89a9167f
LN
951 for my $line (split '\n', $showref) {
952 if ( $line =~ m% refs/heads/(.*)$% ) {
953 print "M $1\t$1\n";
954 }
955 }
956 print "ok\n";
957 return 1;
958 }
959
61717661
MO
960 my $stickyInfo = { 'tag' => $state->{opt}{r},
961 'date' => $state->{opt}{D} };
962
3fda8c4c 963 my $module = $state->{args}[0];
8a06a632 964 $state->{module} = $module;
3fda8c4c
ML
965 my $checkout_path = $module;
966
967 # use the user specified directory if we're given it
968 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
969
970 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
971
972 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
973
974 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
975
976 # Grab a handle to the SQLite db and do any necessary updates
977 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
978 $updater->update();
979
61717661
MO
980 my $headHash;
981 if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
982 {
983 $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
984 if( !defined($headHash) )
985 {
986 print "error 1 no such tag `$stickyInfo->{tag}'\n";
987 cleanupWorkTree();
988 exit;
989 }
990 }
c8c4f220 991
61717661 992 $checkout_path =~ s|/$||; # get rid of trailing slashes
c8c4f220
ML
993
994 my %seendirs = ();
501c7372 995 my $lastdir ='';
3fda8c4c 996
61717661
MO
997 prepDirForOutput(
998 ".",
999 $state->{CVSROOT} . "/$module",
1000 $checkout_path,
1001 \%seendirs,
1002 'checkout',
1003 $state->{dirArgs} );
1004
1005 foreach my $git ( @{$updater->getAnyHead($headHash)} )
3fda8c4c
ML
1006 {
1007 # Don't want to check out deleted files
1008 next if ( $git->{filehash} eq "deleted" );
1009
8a06a632 1010 my $fullName = $git->{name};
3fda8c4c
ML
1011 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
1012
61717661
MO
1013 unless (exists($seendirs{$git->{dir}})) {
1014 prepDirForOutput($git->{dir}, $state->{CVSROOT} . "/$module/",
1015 $checkout_path, \%seendirs, 'checkout',
1016 $state->{dirArgs} );
1017 $lastdir = $git->{dir};
1018 $seendirs{$git->{dir}} = 1;
1019 }
6be32d47 1020
3fda8c4c
ML
1021 # modification time of this file
1022 print "Mod-time $git->{modified}\n";
1023
1024 # print some information to the client
3fda8c4c
ML
1025 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
1026 {
c8c4f220 1027 print "M U $checkout_path/$git->{dir}$git->{name}\n";
3fda8c4c 1028 } else {
c8c4f220 1029 print "M U $checkout_path/$git->{name}\n";
3fda8c4c 1030 }
c8c4f220 1031
6be32d47
ML
1032 # instruct client we're sending a file to put in this path
1033 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
3fda8c4c 1034
6be32d47 1035 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
3fda8c4c
ML
1036
1037 # this is an "entries" line
90948a42 1038 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
61717661
MO
1039 print "/$git->{name}/$git->{revision}//$kopts/" .
1040 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
1041 # permissions
1042 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1043
1044 # transmit file
1045 transmitfile($git->{filehash});
1046 }
1047
1048 print "ok\n";
1049
1050 statecleanup();
1051}
1052
61717661
MO
1053# used by req_co and req_update to set up directories for files
1054# recursively handles parents
1055sub prepDirForOutput
1056{
1057 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1058
1059 my $parent = dirname($dir);
1060 $dir =~ s|/+$||;
1061 $repodir =~ s|/+$||;
1062 $remotedir =~ s|/+$||;
1063 $parent =~ s|/+$||;
1064
1065 if ($parent eq '.' || $parent eq './')
1066 {
1067 $parent = '';
1068 }
1069 # recurse to announce unseen parents first
1070 if( length($parent) &&
1071 !exists($seendirs->{$parent}) &&
1072 ( $request eq "checkout" ||
1073 exists($dirArgs->{$parent}) ) )
1074 {
1075 prepDirForOutput($parent, $repodir, $remotedir,
1076 $seendirs, $request, $dirArgs);
1077 }
1078 # Announce that we are going to modify at the parent level
1079 if ($dir eq '.' || $dir eq './')
1080 {
1081 $dir = '';
1082 }
1083 if(exists($seendirs->{$dir}))
1084 {
1085 return;
1086 }
1087 $log->debug("announcedir $dir, $repodir, $remotedir" );
1088 my($thisRemoteDir,$thisRepoDir);
1089 if ($dir ne "")
1090 {
1091 $thisRepoDir="$repodir/$dir";
1092 if($remotedir eq ".")
1093 {
1094 $thisRemoteDir=$dir;
1095 }
1096 else
1097 {
1098 $thisRemoteDir="$remotedir/$dir";
1099 }
1100 }
1101 else
1102 {
1103 $thisRepoDir=$repodir;
1104 $thisRemoteDir=$remotedir;
1105 }
1106 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1107 {
1108 print "E cvs $request: Updating $thisRemoteDir\n";
1109 }
1110
1111 my ($opt_r)=$state->{opt}{r};
1112 my $stickyInfo;
1113 if(exists($state->{opt}{A}))
1114 {
1115 # $stickyInfo=undef;
1116 }
1117 elsif( defined($opt_r) && $opt_r ne "" )
1118 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1119 {
1120 $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
1121
1122 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
1123 # similar to an entry line's sticky date, without the D prefix.
1124 # It sometimes (always?) arrives as something more like
1125 # '10 Apr 2011 04:46:57 -0000'...
1126 # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
1127 }
1128 else
1129 {
1130 $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
1131 }
1132
1133 my $stickyResponse;
1134 if(defined($stickyInfo))
1135 {
1136 $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1137 "$thisRepoDir/\n" .
1138 getStickyTagOrDate($stickyInfo) . "\n";
1139 }
1140 else
1141 {
1142 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1143 "$thisRepoDir/\n";
1144 }
1145
1146 unless ( $state->{globaloptions}{-n} )
1147 {
1148 print $stickyResponse;
1149
1150 print "Clear-static-directory $thisRemoteDir/\n";
1151 print "$thisRepoDir/\n";
1152 print $stickyResponse; # yes, twice
1153 print "Template $thisRemoteDir/\n";
1154 print "$thisRepoDir/\n";
1155 print "0\n";
1156 }
1157
1158 $seendirs->{$dir} = 1;
1159
1160 # FUTURE: This would more accurately emulate CVS by sending
1161 # another copy of sticky after processing the files in that
1162 # directory. Or intermediate: perhaps send all sticky's for
832c0e5e 1163 # $seendirs after processing all files.
61717661
MO
1164}
1165
3fda8c4c
ML
1166# update \n
1167# Response expected: yes. Actually do a cvs update command. This uses any
1168# previous Argument, Directory, Entry, or Modified requests, if they have
1169# been sent. The last Directory sent specifies the working directory at the
1170# time of the operation. The -I option is not used--files which the client
1171# can decide whether to ignore are not mentioned and the client sends the
1172# Questionable request for others.
1173sub req_update
1174{
1175 my ( $cmd, $data ) = @_;
1176
1177 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1178
1179 argsplit("update");
1180
858cbfba 1181 #
5348b6e7 1182 # It may just be a client exploring the available heads/modules
858cbfba
ML
1183 # in that case, list them as top level directories and leave it
1184 # at that. Eclipse uses this technique to offer you a list of
1185 # projects (heads in this case) to checkout.
1186 #
1187 if ($state->{module} eq '') {
46203ac2 1188 my $showref = safe_pipe_capture(qw(git show-ref --heads));
858cbfba 1189 print "E cvs update: Updating .\n";
b20171eb
LN
1190 for my $line (split '\n', $showref) {
1191 if ( $line =~ m% refs/heads/(.*)$% ) {
1192 print "E cvs update: New directory `$1'\n";
1193 }
1194 }
1195 print "ok\n";
1196 return 1;
858cbfba
ML
1197 }
1198
1199
3fda8c4c
ML
1200 # Grab a handle to the SQLite db and do any necessary updates
1201 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1202
1203 $updater->update();
1204
7d90095a 1205 argsfromdir($updater);
3fda8c4c
ML
1206
1207 #$log->debug("update state : " . Dumper($state));
1208
61717661
MO
1209 my($repoDir);
1210 $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
1211
1212 my %seendirs = ();
8e4c4e7d 1213
addf88e4 1214 # foreach file specified on the command line ...
61717661 1215 foreach my $argsFilename ( @{$state->{args}} )
3fda8c4c 1216 {
61717661
MO
1217 my $filename;
1218 $filename = filecleanup($argsFilename);
3fda8c4c 1219
7d90095a
MS
1220 $log->debug("Processing file $filename");
1221
3fda8c4c
ML
1222 # if we have a -C we should pretend we never saw modified stuff
1223 if ( exists ( $state->{opt}{C} ) )
1224 {
1225 delete $state->{entries}{$filename}{modified_hash};
1226 delete $state->{entries}{$filename}{modified_filename};
1227 $state->{entries}{$filename}{unchanged} = 1;
1228 }
1229
61717661
MO
1230 my $stickyInfo = resolveStickyInfo($filename,
1231 $state->{opt}{r},
1232 $state->{opt}{D},
1233 exists($state->{opt}{A}));
1234 my $meta = $updater->getmeta($filename, $stickyInfo);
3fda8c4c 1235
e78f69a3
DD
1236 # If -p was given, "print" the contents of the requested revision.
1237 if ( exists ( $state->{opt}{p} ) ) {
1238 if ( defined ( $meta->{revision} ) ) {
1239 $log->info("Printing '$filename' revision " . $meta->{revision});
1240
1241 transmitfile($meta->{filehash}, { print => 1 });
1242 }
1243
1244 next;
1245 }
1246
61717661
MO
1247 # Directories:
1248 prepDirForOutput(
1249 dirname($argsFilename),
1250 $repoDir,
1251 ".",
1252 \%seendirs,
1253 "update",
1254 $state->{dirArgs} );
1255
1256 my $wrev = revparse($filename);
1257
0a7a9a12
JS
1258 if ( ! defined $meta )
1259 {
1260 $meta = {
1261 name => $filename,
ab07681f 1262 revision => '0',
0a7a9a12
JS
1263 filehash => 'added'
1264 };
61717661
MO
1265 if($wrev ne "0")
1266 {
1267 $meta->{filehash}='deleted';
1268 }
0a7a9a12 1269 }
3fda8c4c
ML
1270
1271 my $oldmeta = $meta;
1272
3fda8c4c 1273 # If the working copy is an old revision, lets get that version too for comparison.
61717661
MO
1274 my $oldWrev=$wrev;
1275 if(defined($oldWrev))
3fda8c4c 1276 {
61717661
MO
1277 $oldWrev=~s/^-//;
1278 if($oldWrev ne $meta->{revision})
1279 {
1280 $oldmeta = $updater->getmeta($filename, $oldWrev);
1281 }
3fda8c4c
ML
1282 }
1283
1284 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1285
ec58db15
ML
1286 # Files are up to date if the working copy and repo copy have the same revision,
1287 # and the working copy is unmodified _and_ the user hasn't specified -C
1288 next if ( defined ( $wrev )
1289 and defined($meta->{revision})
ab07681f 1290 and $wrev eq $meta->{revision}
ec58db15
ML
1291 and $state->{entries}{$filename}{unchanged}
1292 and not exists ( $state->{opt}{C} ) );
1293
1294 # If the working copy and repo copy have the same revision,
1295 # but the working copy is modified, tell the client it's modified
1296 if ( defined ( $wrev )
1297 and defined($meta->{revision})
ab07681f 1298 and $wrev eq $meta->{revision}
61717661 1299 and $wrev ne "0"
cb52d9a1 1300 and defined($state->{entries}{$filename}{modified_hash})
ec58db15
ML
1301 and not exists ( $state->{opt}{C} ) )
1302 {
1303 $log->info("Tell the client the file is modified");
0a7a9a12 1304 print "MT text M \n";
ec58db15
ML
1305 print "MT fname $filename\n";
1306 print "MT newline\n";
1307 next;
1308 }
3fda8c4c 1309
61717661 1310 if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
3fda8c4c 1311 {
d8574ff2
MO
1312 # TODO: If it has been modified in the sandbox, error out
1313 # with the appropriate message, rather than deleting a modified
1314 # file.
1315
7d90095a 1316 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
3fda8c4c
ML
1317
1318 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1319
1320 print "E cvs update: `$filename' is no longer in the repository\n";
7d90095a
MS
1321 # Don't want to actually _DO_ the update if -n specified
1322 unless ( $state->{globaloptions}{-n} ) {
1323 print "Removed $dirpart\n";
1324 print "$filepart\n";
1325 }
3fda8c4c 1326 }
ec58db15 1327 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
0a7a9a12
JS
1328 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1329 or $meta->{filehash} eq 'added' )
3fda8c4c 1330 {
0a7a9a12
JS
1331 # normal update, just send the new revision (either U=Update,
1332 # or A=Add, or R=Remove)
ab07681f 1333 if ( defined($wrev) && ($wrev=~/^-/) )
0a7a9a12
JS
1334 {
1335 $log->info("Tell the client the file is scheduled for removal");
1336 print "MT text R \n";
1337 print "MT fname $filename\n";
1338 print "MT newline\n";
1339 next;
1340 }
ab07681f
MO
1341 elsif ( (!defined($wrev) || $wrev eq '0') &&
1342 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
0a7a9a12 1343 {
535514f1 1344 $log->info("Tell the client the file is scheduled for addition");
0a7a9a12
JS
1345 print "MT text A \n";
1346 print "MT fname $filename\n";
1347 print "MT newline\n";
1348 next;
1349
1350 }
1351 else {
ab07681f 1352 $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
0a7a9a12
JS
1353 print "MT +updated\n";
1354 print "MT text U \n";
1355 print "MT fname $filename\n";
1356 print "MT newline\n";
1357 print "MT -updated\n";
1358 }
3fda8c4c 1359
7d90095a
MS
1360 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1361
1362 # Don't want to actually _DO_ the update if -n specified
1363 unless ( $state->{globaloptions}{-n} )
1364 {
1365 if ( defined ( $wrev ) )
1366 {
1367 # instruct client we're sending a file to put in this path as a replacement
1368 print "Update-existing $dirpart\n";
1369 $log->debug("Updating existing file 'Update-existing $dirpart'");
1370 } else {
1371 # instruct client we're sending a file to put in this path as a new file
7d90095a
MS
1372
1373 $log->debug("Creating new file 'Created $dirpart'");
1374 print "Created $dirpart\n";
1375 }
1376 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1377
1378 # this is an "entries" line
90948a42 1379 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
1380 my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
1381 $entriesLine .= getStickyTagOrDate($stickyInfo);
1382 $log->debug($entriesLine);
1383 print "$entriesLine\n";
7d90095a
MS
1384
1385 # permissions
1386 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1387 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1388
1389 # transmit file
1390 transmitfile($meta->{filehash});
1391 }
3fda8c4c 1392 } else {
7d90095a 1393 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
3fda8c4c 1394
044182ef 1395 my $mergeDir = setupTmpDir();
3fda8c4c 1396
3fda8c4c 1397 my $file_local = $filepart . ".mine";
044182ef 1398 my $mergedFile = "$mergeDir/$file_local";
3fda8c4c
ML
1399 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1400 my $file_old = $filepart . "." . $oldmeta->{revision};
e78f69a3 1401 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
3fda8c4c 1402 my $file_new = $filepart . "." . $meta->{revision};
e78f69a3 1403 transmitfile($meta->{filehash}, { targetfile => $file_new });
3fda8c4c
ML
1404
1405 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1406 $log->info("Merging $file_local, $file_old, $file_new");
ab07681f 1407 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
3fda8c4c 1408
044182ef 1409 $log->debug("Temporary directory for merge is $mergeDir");
3fda8c4c 1410
c6b4fa96 1411 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
3fda8c4c
ML
1412 $return >>= 8;
1413
044182ef
MO
1414 cleanupTmpDir();
1415
3fda8c4c
ML
1416 if ( $return == 0 )
1417 {
1418 $log->info("Merged successfully");
1419 print "M M $filename\n";
53877846 1420 $log->debug("Merged $dirpart");
7d90095a
MS
1421
1422 # Don't want to actually _DO_ the update if -n specified
1423 unless ( $state->{globaloptions}{-n} )
1424 {
53877846 1425 print "Merged $dirpart\n";
7d90095a
MS
1426 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1427 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
90948a42
MO
1428 my $kopts = kopts_from_path("$dirpart/$filepart",
1429 "file",$mergedFile);
ab07681f 1430 $log->debug("/$filepart/$meta->{revision}//$kopts/");
61717661
MO
1431 my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
1432 $entriesLine .= getStickyTagOrDate($stickyInfo);
1433 print "$entriesLine\n";
7d90095a 1434 }
3fda8c4c
ML
1435 }
1436 elsif ( $return == 1 )
1437 {
1438 $log->info("Merged with conflicts");
459bad77 1439 print "E cvs update: conflicts found in $filename\n";
3fda8c4c 1440 print "M C $filename\n";
7d90095a
MS
1441
1442 # Don't want to actually _DO_ the update if -n specified
1443 unless ( $state->{globaloptions}{-n} )
1444 {
53877846 1445 print "Merged $dirpart\n";
7d90095a 1446 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
90948a42
MO
1447 my $kopts = kopts_from_path("$dirpart/$filepart",
1448 "file",$mergedFile);
61717661
MO
1449 my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
1450 $entriesLine .= getStickyTagOrDate($stickyInfo);
1451 print "$entriesLine\n";
7d90095a 1452 }
3fda8c4c
ML
1453 }
1454 else
1455 {
1456 $log->warn("Merge failed");
1457 next;
1458 }
1459
7d90095a
MS
1460 # Don't want to actually _DO_ the update if -n specified
1461 unless ( $state->{globaloptions}{-n} )
1462 {
1463 # permissions
1464 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1465 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1466
1467 # transmit file, format is single integer on a line by itself (file
1468 # size) followed by the file contents
1469 # TODO : we should copy files in blocks
27dd7387 1470 my $data = safe_pipe_capture('cat', $mergedFile);
7d90095a
MS
1471 $log->debug("File size : " . length($data));
1472 print length($data) . "\n";
1473 print $data;
1474 }
3fda8c4c
ML
1475 }
1476
1477 }
1478
61717661
MO
1479 # prepDirForOutput() any other existing directories unless they already
1480 # have the right sticky tag:
1481 unless ( $state->{globaloptions}{n} )
1482 {
1483 my $dir;
1484 foreach $dir (keys(%{$state->{dirMap}}))
1485 {
1486 if( ! $seendirs{$dir} &&
1487 exists($state->{dirArgs}{$dir}) )
1488 {
1489 my($oldTag);
1490 $oldTag=$state->{dirMap}{$dir}{tagspec};
1491
1492 unless( ( exists($state->{opt}{A}) &&
1493 defined($oldTag) ) ||
1494 ( defined($state->{opt}{r}) &&
1495 ( !defined($oldTag) ||
1496 $state->{opt}{r} ne $oldTag ) ) )
1497 # TODO?: OR sticky dir is different...
1498 {
1499 next;
1500 }
1501
1502 prepDirForOutput(
1503 $dir,
1504 $repoDir,
1505 ".",
1506 \%seendirs,
1507 'update',
1508 $state->{dirArgs} );
1509 }
1510
1511 # TODO?: Consider sending a final duplicate Sticky response
1512 # to more closely mimic real CVS.
1513 }
1514 }
1515
3fda8c4c
ML
1516 print "ok\n";
1517}
1518
1519sub req_ci
1520{
1521 my ( $cmd, $data ) = @_;
1522
1523 argsplit("ci");
1524
1525 #$log->debug("State : " . Dumper($state));
1526
1527 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1528
031a027a 1529 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
91a6bf46 1530 {
031a027a 1531 print "error 1 anonymous user cannot commit via pserver\n";
044182ef 1532 cleanupWorkTree();
91a6bf46
ML
1533 exit;
1534 }
1535
3fda8c4c
ML
1536 if ( -e $state->{CVSROOT} . "/index" )
1537 {
568907f5 1538 $log->warn("file 'index' already exists in the git repository");
3fda8c4c 1539 print "error 1 Index already exists in git repo\n";
044182ef 1540 cleanupWorkTree();
3fda8c4c
ML
1541 exit;
1542 }
1543
3fda8c4c
ML
1544 # Grab a handle to the SQLite db and do any necessary updates
1545 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1546 $updater->update();
1547
3fda8c4c 1548 my @committedfiles = ();
392e2817 1549 my %oldmeta;
61717661
MO
1550 my $stickyInfo;
1551 my $branchRef;
1552 my $parenthash;
3fda8c4c 1553
addf88e4 1554 # foreach file specified on the command line ...
3fda8c4c
ML
1555 foreach my $filename ( @{$state->{args}} )
1556 {
7d90095a 1557 my $committedfile = $filename;
3fda8c4c
ML
1558 $filename = filecleanup($filename);
1559
1560 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1561
61717661
MO
1562 #####
1563 # Figure out which branch and parenthash we are committing
1564 # to, and setup worktree:
1565
1566 # should always come from entries:
1567 my $fileStickyInfo = resolveStickyInfo($filename);
1568 if( !defined($branchRef) )
1569 {
1570 $stickyInfo = $fileStickyInfo;
1571 if( defined($stickyInfo) &&
1572 ( defined($stickyInfo->{date}) ||
1573 !defined($stickyInfo->{tag}) ) )
1574 {
1575 print "error 1 cannot commit with sticky date for file `$filename'\n";
1576 cleanupWorkTree();
1577 exit;
1578 }
1579
1580 $branchRef = "refs/heads/$state->{module}";
1581 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1582 {
1583 $branchRef = "refs/heads/$stickyInfo->{tag}";
1584 }
1585
27dd7387 1586 $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
61717661 1587 chomp $parenthash;
05ea93d6 1588 if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/)
61717661
MO
1589 {
1590 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1591 {
1592 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1593 }
1594 else
1595 {
1596 print "error 1 pserver cannot find the current HEAD of module";
1597 }
1598 cleanupWorkTree();
1599 exit;
1600 }
1601
1602 setupWorkTree($parenthash);
1603
1604 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1605
1606 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1607 }
1608 elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
1609 {
1610 #TODO: We could split the cvs commit into multiple
1611 # git commits by distinct stickyTag values, but that
1612 # is lowish priority.
1613 print "error 1 Committing different files to different"
1614 . " branches is not currently supported\n";
1615 cleanupWorkTree();
1616 exit;
1617 }
1618
1619 #####
1620 # Process this file:
1621
1622 my $meta = $updater->getmeta($filename,$stickyInfo);
392e2817 1623 $oldmeta{$filename} = $meta;
3fda8c4c
ML
1624
1625 my $wrev = revparse($filename);
1626
1627 my ( $filepart, $dirpart ) = filenamesplit($filename);
1628
cdf63284 1629 # do a checkout of the file if it is part of this tree
3fda8c4c 1630 if ($wrev) {
d2feb01a 1631 system('git', 'checkout-index', '-f', '-u', $filename);
3fda8c4c
ML
1632 unless ($? == 0) {
1633 die "Error running git-checkout-index -f -u $filename : $!";
1634 }
1635 }
1636
1637 my $addflag = 0;
1638 my $rmflag = 0;
ab07681f 1639 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
3fda8c4c
ML
1640 $addflag = 1 unless ( -e $filename );
1641
1642 # Do up to date checking
ab07681f
MO
1643 unless ( $addflag or $wrev eq $meta->{revision} or
1644 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
3fda8c4c
ML
1645 {
1646 # fail everything if an up to date check fails
1647 print "error 1 Up to date check failed for $filename\n";
044182ef 1648 cleanupWorkTree();
3fda8c4c
ML
1649 exit;
1650 }
1651
7d90095a 1652 push @committedfiles, $committedfile;
3fda8c4c
ML
1653 $log->info("Committing $filename");
1654
1655 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1656
1657 unless ( $rmflag )
1658 {
1659 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1660 rename $state->{entries}{$filename}{modified_filename},$filename;
1661
1662 # Calculate modes to remove
1663 my $invmode = "";
1664 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1665
1666 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1667 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1668 }
1669
1670 if ( $rmflag )
1671 {
1672 $log->info("Removing file '$filename'");
1673 unlink($filename);
d2feb01a 1674 system("git", "update-index", "--remove", $filename);
3fda8c4c
ML
1675 }
1676 elsif ( $addflag )
1677 {
1678 $log->info("Adding file '$filename'");
d2feb01a 1679 system("git", "update-index", "--add", $filename);
3fda8c4c 1680 } else {
ab07681f 1681 $log->info("UpdatingX2 file '$filename'");
d2feb01a 1682 system("git", "update-index", $filename);
3fda8c4c
ML
1683 }
1684 }
1685
1686 unless ( scalar(@committedfiles) > 0 )
1687 {
1688 print "E No files to commit\n";
1689 print "ok\n";
044182ef 1690 cleanupWorkTree();
3fda8c4c
ML
1691 return;
1692 }
1693
46203ac2 1694 my $treehash = safe_pipe_capture(qw(git write-tree));
3fda8c4c 1695 chomp $treehash;
3fda8c4c
ML
1696
1697 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1698
1699 # write our commit message out if we have one ...
1700 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1701 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
280514e1
FE
1702 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1703 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1704 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1705 }
1706 } else {
1707 print $msg_fh "\n\nvia git-CVS emulator\n";
1708 }
3fda8c4c
ML
1709 close $msg_fh;
1710
27dd7387 1711 my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1872adab 1712 chomp($commithash);
3fda8c4c
ML
1713 $log->info("Commit hash : $commithash");
1714
05ea93d6 1715 unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ )
3fda8c4c
ML
1716 {
1717 $log->warn("Commit failed (Invalid commit hash)");
1718 print "error 1 Commit failed (unknown reason)\n";
044182ef 1719 cleanupWorkTree();
3fda8c4c
ML
1720 exit;
1721 }
1722
cdf63284 1723 ### Emulate git-receive-pack by running hooks/update
61717661 1724 my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef,
b2741f63 1725 $parenthash, $commithash );
cdf63284
MW
1726 if( -x $hook[0] ) {
1727 unless( system( @hook ) == 0 )
b2741f63
AP
1728 {
1729 $log->warn("Commit failed (update hook declined to update ref)");
1730 print "error 1 Commit failed (update hook declined)\n";
044182ef 1731 cleanupWorkTree();
b2741f63
AP
1732 exit;
1733 }
1734 }
1735
cdf63284 1736 ### Update the ref
ada5ef3b 1737 if (system(qw(git update-ref -m), "cvsserver ci",
61717661 1738 $branchRef, $commithash, $parenthash)) {
ada5ef3b
JH
1739 $log->warn("update-ref for $state->{module} failed.");
1740 print "error 1 Cannot commit -- update first\n";
044182ef 1741 cleanupWorkTree();
ada5ef3b
JH
1742 exit;
1743 }
3fda8c4c 1744
cdf63284
MW
1745 ### Emulate git-receive-pack by running hooks/post-receive
1746 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1747 if( -x $hook ) {
1748 open(my $pipe, "| $hook") || die "can't fork $!";
1749
1750 local $SIG{PIPE} = sub { die 'pipe broke' };
1751
61717661 1752 print $pipe "$parenthash $commithash $branchRef\n";
cdf63284
MW
1753
1754 close $pipe || die "bad pipe: $! $?";
1755 }
1756
ad8c3477
SK
1757 $updater->update();
1758
394d66d4
JH
1759 ### Then hooks/post-update
1760 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1761 if (-x $hook) {
61717661 1762 system($hook, $branchRef);
394d66d4
JH
1763 }
1764
addf88e4 1765 # foreach file specified on the command line ...
3fda8c4c
ML
1766 foreach my $filename ( @committedfiles )
1767 {
1768 $filename = filecleanup($filename);
1769
61717661 1770 my $meta = $updater->getmeta($filename,$stickyInfo);
3486595b 1771 unless (defined $meta->{revision}) {
ab07681f 1772 $meta->{revision} = "1.1";
3486595b 1773 }
3fda8c4c 1774
7d90095a 1775 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
1776
1777 $log->debug("Checked-in $dirpart : $filename");
1778
392e2817 1779 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
3486595b 1780 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
3fda8c4c 1781 {
ab07681f 1782 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
3fda8c4c
ML
1783 print "Remove-entry $dirpart\n";
1784 print "$filename\n";
1785 } else {
ab07681f 1786 if ($meta->{revision} eq "1.1") {
459bad77
FL
1787 print "M initial revision: 1.1\n";
1788 } else {
ab07681f 1789 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
459bad77 1790 }
3fda8c4c
ML
1791 print "Checked-in $dirpart\n";
1792 print "$filename\n";
90948a42 1793 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
1794 print "/$filepart/$meta->{revision}//$kopts/" .
1795 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
1796 }
1797 }
1798
044182ef 1799 cleanupWorkTree();
3fda8c4c
ML
1800 print "ok\n";
1801}
1802
1803sub req_status
1804{
1805 my ( $cmd, $data ) = @_;
1806
1807 argsplit("status");
1808
1809 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1810 #$log->debug("status state : " . Dumper($state));
1811
1812 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
1813 my $updater;
1814 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
1815 $updater->update();
1816
4d804c0e
MO
1817 # if no files were specified, we need to work out what files we should
1818 # be providing status on ...
7d90095a 1819 argsfromdir($updater);
3fda8c4c 1820
addf88e4 1821 # foreach file specified on the command line ...
3fda8c4c
ML
1822 foreach my $filename ( @{$state->{args}} )
1823 {
1824 $filename = filecleanup($filename);
1825
4d804c0e
MO
1826 if ( exists($state->{opt}{l}) &&
1827 index($filename, '/', length($state->{prependdir})) >= 0 )
1828 {
1829 next;
1830 }
852b921c 1831
3fda8c4c
ML
1832 my $wrev = revparse($filename);
1833
61717661
MO
1834 my $stickyInfo = resolveStickyInfo($filename);
1835 my $meta = $updater->getmeta($filename,$stickyInfo);
1836 my $oldmeta = $meta;
1837
4d804c0e
MO
1838 # If the working copy is an old revision, lets get that
1839 # version too for comparison.
ab07681f 1840 if ( defined($wrev) and $wrev ne $meta->{revision} )
3fda8c4c 1841 {
61717661
MO
1842 my($rmRev)=$wrev;
1843 $rmRev=~s/^-//;
1844 $oldmeta = $updater->getmeta($filename, $rmRev);
3fda8c4c
ML
1845 }
1846
1847 # TODO : All possible statuses aren't yet implemented
1848 my $status;
4d804c0e
MO
1849 # Files are up to date if the working copy and repo copy have
1850 # the same revision, and the working copy is unmodified
1851 if ( defined ( $wrev ) and defined($meta->{revision}) and
ab07681f 1852 $wrev eq $meta->{revision} and
4d804c0e
MO
1853 ( ( $state->{entries}{$filename}{unchanged} and
1854 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1855 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1856 ( defined($state->{entries}{$filename}{modified_hash}) and
1857 $state->{entries}{$filename}{modified_hash} eq
ab07681f 1858 $meta->{filehash} ) ) )
4d804c0e 1859 {
ab07681f 1860 $status = "Up-to-date"
4d804c0e
MO
1861 }
1862
ab07681f
MO
1863 # Need checkout if the working copy has a different (usually
1864 # older) revision than the repo copy, and the working copy is
1865 # unmodified
4d804c0e 1866 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1867 $meta->{revision} ne $wrev and
4d804c0e
MO
1868 ( $state->{entries}{$filename}{unchanged} or
1869 ( defined($state->{entries}{$filename}{modified_hash}) and
1870 $state->{entries}{$filename}{modified_hash} eq
1871 $oldmeta->{filehash} ) ) )
1872 {
1873 $status ||= "Needs Checkout";
1874 }
1875
1876 # Need checkout if it exists in the repo but doesn't have a working
1877 # copy
1878 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1879 {
1880 $status ||= "Needs Checkout";
1881 }
1882
1883 # Locally modified if working copy and repo copy have the
1884 # same revision but there are local changes
1885 if ( defined ( $wrev ) and defined($meta->{revision}) and
ab07681f 1886 $wrev eq $meta->{revision} and
61717661 1887 $wrev ne "0" and
4d804c0e
MO
1888 $state->{entries}{$filename}{modified_filename} )
1889 {
1890 $status ||= "Locally Modified";
1891 }
1892
ab07681f
MO
1893 # Needs Merge if working copy revision is different
1894 # (usually older) than repo copy and there are local changes
4d804c0e 1895 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1896 $meta->{revision} ne $wrev and
4d804c0e
MO
1897 $state->{entries}{$filename}{modified_filename} )
1898 {
1899 $status ||= "Needs Merge";
1900 }
1901
1902 if ( defined ( $state->{entries}{$filename}{revision} ) and
61717661
MO
1903 ( !defined($meta->{revision}) ||
1904 $meta->{revision} eq "0" ) )
4d804c0e
MO
1905 {
1906 $status ||= "Locally Added";
1907 }
1908 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1909 $wrev eq "-$meta->{revision}" )
4d804c0e
MO
1910 {
1911 $status ||= "Locally Removed";
1912 }
1913 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1914 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1915 {
1916 $status ||= "Unresolved Conflict";
1917 }
1918 if ( 0 )
1919 {
1920 $status ||= "File had conflicts on merge";
1921 }
3fda8c4c
ML
1922
1923 $status ||= "Unknown";
1924
23b7180f
DD
1925 my ($filepart) = filenamesplit($filename);
1926
4d804c0e 1927 print "M =======" . ( "=" x 60 ) . "\n";
23b7180f 1928 print "M File: $filepart\tStatus: $status\n";
3fda8c4c
ML
1929 if ( defined($state->{entries}{$filename}{revision}) )
1930 {
4d804c0e
MO
1931 print "M Working revision:\t" .
1932 $state->{entries}{$filename}{revision} . "\n";
3fda8c4c
ML
1933 } else {
1934 print "M Working revision:\tNo entry for $filename\n";
1935 }
1936 if ( defined($meta->{revision}) )
1937 {
ab07681f 1938 print "M Repository revision:\t" .
4d804c0e
MO
1939 $meta->{revision} .
1940 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
abd66f22
MO
1941 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
1942 my($tag)=($tagOrDate=~m/^T(.+)$/);
1943 if( !defined($tag) )
1944 {
1945 $tag="(none)";
1946 }
1947 print "M Sticky Tag:\t\t$tag\n";
1948 my($date)=($tagOrDate=~m/^D(.+)$/);
1949 if( !defined($date) )
1950 {
1951 $date="(none)";
1952 }
1953 print "M Sticky Date:\t\t$date\n";
1954 my($options)=$state->{entries}{$filename}{options};
1955 if( $options eq "" )
1956 {
1957 $options="(none)";
1958 }
1959 print "M Sticky Options:\t\t$options\n";
3fda8c4c
ML
1960 } else {
1961 print "M Repository revision:\tNo revision control file\n";
1962 }
1963 print "M\n";
1964 }
1965
1966 print "ok\n";
1967}
1968
1969sub req_diff
1970{
1971 my ( $cmd, $data ) = @_;
1972
1973 argsplit("diff");
1974
1975 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1976 #$log->debug("status state : " . Dumper($state));
1977
1978 my ($revision1, $revision2);
1979 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1980 {
1981 $revision1 = $state->{opt}{r}[0];
1982 $revision2 = $state->{opt}{r}[1];
1983 } else {
1984 $revision1 = $state->{opt}{r};
1985 }
1986
4d804c0e
MO
1987 $log->debug("Diffing revisions " .
1988 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1989 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
3fda8c4c
ML
1990
1991 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
1992 my $updater;
1993 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
1994 $updater->update();
1995
4d804c0e
MO
1996 # if no files were specified, we need to work out what files we should
1997 # be providing status on ...
7d90095a 1998 argsfromdir($updater);
3fda8c4c 1999
61717661
MO
2000 my($foundDiff);
2001
addf88e4 2002 # foreach file specified on the command line ...
61717661 2003 foreach my $argFilename ( @{$state->{args}} )
3fda8c4c 2004 {
61717661 2005 my($filename) = filecleanup($argFilename);
3fda8c4c
ML
2006
2007 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2008
2009 my $wrev = revparse($filename);
2010
61717661
MO
2011 # Priority for revision1:
2012 # 1. First -r (missing file: check -N)
2013 # 2. wrev from client's Entry line
2014 # - missing line/file: check -N
2015 # - "0": added file not committed (empty contents for rev1)
2016 # - Prefixed with dash (to be removed): check -N
3fda8c4c 2017
3fda8c4c
ML
2018 if ( defined ( $revision1 ) )
2019 {
3fda8c4c 2020 $meta1 = $updater->getmeta($filename, $revision1);
61717661
MO
2021 }
2022 elsif( defined($wrev) && $wrev ne "0" )
2023 {
2024 my($rmRev)=$wrev;
2025 $rmRev=~s/^-//;
2026 $meta1 = $updater->getmeta($filename, $rmRev);
2027 }
2028 if ( !defined($meta1) ||
2029 $meta1->{filehash} eq "deleted" )
2030 {
2031 if( !exists($state->{opt}{N}) )
3fda8c4c 2032 {
61717661
MO
2033 if(!defined($revision1))
2034 {
2035 print "E File $filename at revision $revision1 doesn't exist\n";
2036 }
3fda8c4c
ML
2037 next;
2038 }
61717661
MO
2039 elsif( !defined($meta1) )
2040 {
2041 $meta1 = {
2042 name => $filename,
2043 revision => '0',
2044 filehash => 'deleted'
2045 };
2046 }
3fda8c4c
ML
2047 }
2048
61717661
MO
2049 # Priority for revision2:
2050 # 1. Second -r (missing file: check -N)
2051 # 2. Modified file contents from client
2052 # 3. wrev from client's Entry line
2053 # - missing line/file: check -N
2054 # - Prefixed with dash (to be removed): check -N
2055
3fda8c4c
ML
2056 # if we have a second -r switch, use it too
2057 if ( defined ( $revision2 ) )
2058 {
3fda8c4c 2059 $meta2 = $updater->getmeta($filename, $revision2);
3fda8c4c 2060 }
61717661 2061 elsif(defined($state->{entries}{$filename}{modified_filename}))
3fda8c4c
ML
2062 {
2063 $file2 = $state->{entries}{$filename}{modified_filename};
61717661
MO
2064 $meta2 = {
2065 name => $filename,
2066 revision => '0',
2067 filehash => 'modified'
2068 };
3fda8c4c 2069 }
61717661 2070 elsif( defined($wrev) && ($wrev!~/^-/) )
3fda8c4c 2071 {
61717661
MO
2072 if(!defined($revision1)) # no revision and no modifications:
2073 {
2074 next;
2075 }
3fda8c4c 2076 $meta2 = $updater->getmeta($filename, $wrev);
61717661
MO
2077 }
2078 if(!defined($file2))
2079 {
2080 if ( !defined($meta2) ||
2081 $meta2->{filehash} eq "deleted" )
2082 {
2083 if( !exists($state->{opt}{N}) )
2084 {
2085 if(!defined($revision2))
2086 {
2087 print "E File $filename at revision $revision2 doesn't exist\n";
2088 }
2089 next;
2090 }
2091 elsif( !defined($meta2) )
2092 {
2093 $meta2 = {
2094 name => $filename,
2095 revision => '0',
2096 filehash => 'deleted'
2097 };
2098 }
2099 }
3fda8c4c
ML
2100 }
2101
61717661 2102 if( $meta1->{filehash} eq $meta2->{filehash} )
4d804c0e 2103 {
61717661 2104 $log->info("unchanged $filename");
4d804c0e
MO
2105 next;
2106 }
3fda8c4c 2107
61717661
MO
2108 # Retrieve revision contents:
2109 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2110 transmitfile($meta1->{filehash}, { targetfile => $file1 });
2111
2112 if(!defined($file2))
4d804c0e 2113 {
61717661
MO
2114 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2115 transmitfile($meta2->{filehash}, { targetfile => $file2 });
4d804c0e 2116 }
3fda8c4c 2117
61717661
MO
2118 # Generate the actual diff:
2119 print "M Index: $argFilename\n";
4d804c0e 2120 print "M =======" . ( "=" x 60 ) . "\n";
3fda8c4c 2121 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
61717661 2122 if ( defined ( $meta1 ) && $meta1->{revision} ne "0" )
4d804c0e 2123 {
ab07681f 2124 print "M retrieving revision $meta1->{revision}\n"
4d804c0e 2125 }
61717661 2126 if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
4d804c0e 2127 {
ab07681f 2128 print "M retrieving revision $meta2->{revision}\n"
4d804c0e 2129 }
3fda8c4c 2130 print "M diff ";
9462953a 2131 foreach my $opt ( sort keys %{$state->{opt}} )
3fda8c4c
ML
2132 {
2133 if ( ref $state->{opt}{$opt} eq "ARRAY" )
2134 {
2135 foreach my $value ( @{$state->{opt}{$opt}} )
2136 {
2137 print "-$opt $value ";
2138 }
2139 } else {
2140 print "-$opt ";
4d804c0e
MO
2141 if ( defined ( $state->{opt}{$opt} ) )
2142 {
2143 print "$state->{opt}{$opt} "
2144 }
3fda8c4c
ML
2145 }
2146 }
61717661 2147 print "$argFilename\n";
3fda8c4c 2148
4d804c0e
MO
2149 $log->info("Diffing $filename -r $meta1->{revision} -r " .
2150 ( $meta2->{revision} or "workingcopy" ));
3fda8c4c 2151
61717661 2152 # TODO: Use --label instead of -L because -L is no longer
abcb66c6 2153 # documented and may go away someday. Not sure if there are
61717661
MO
2154 # versions that only support -L, which would make this change risky?
2155 # http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html
2156 # ("man diff" should actually document the best migration strategy,
2157 # [current behavior, future changes, old compatibility issues
2158 # or lack thereof, etc], not just stop mentioning the option...)
2159 # TODO: Real CVS seems to include a date in the label, before
2160 # the revision part, without the keyword "revision". The following
2161 # has minimal changes compared to original versions of
2162 # git-cvsserver.perl. (Mostly tab vs space after filename.)
3fda8c4c 2163
61717661
MO
2164 my (@diffCmd) = ( 'diff' );
2165 if ( exists($state->{opt}{N}) )
3fda8c4c 2166 {
61717661 2167 push @diffCmd,"-N";
3fda8c4c 2168 }
61717661
MO
2169 if ( exists $state->{opt}{u} )
2170 {
2171 push @diffCmd,("-u","-L");
2172 if( $meta1->{filehash} eq "deleted" )
2173 {
2174 push @diffCmd,"/dev/null";
2175 } else {
2176 push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2177 }
3fda8c4c 2178
61717661
MO
2179 if( defined($meta2->{filehash}) )
2180 {
2181 if( $meta2->{filehash} eq "deleted" )
2182 {
2183 push @diffCmd,("-L","/dev/null");
2184 } else {
2185 push @diffCmd,("-L",
2186 "$argFilename\trevision $meta2->{revision}");
2187 }
2188 } else {
2189 push @diffCmd,("-L","$argFilename\tworking copy");
2190 }
2191 }
2192 push @diffCmd,($file1,$file2);
2193 if(!open(DIFF,"-|",@diffCmd))
3fda8c4c 2194 {
61717661 2195 $log->warn("Unable to run diff: $!");
3fda8c4c 2196 }
61717661
MO
2197 my($diffLine);
2198 while(defined($diffLine=<DIFF>))
2199 {
2200 print "M $diffLine";
2201 $foundDiff=1;
2202 }
2203 close(DIFF);
3fda8c4c
ML
2204 }
2205
61717661
MO
2206 if($foundDiff)
2207 {
2208 print "error \n";
2209 }
2210 else
2211 {
2212 print "ok\n";
2213 }
3fda8c4c
ML
2214}
2215
2216sub req_log
2217{
2218 my ( $cmd, $data ) = @_;
2219
2220 argsplit("log");
2221
2222 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
2223 #$log->debug("log state : " . Dumper($state));
2224
ab07681f
MO
2225 my ( $revFilter );
2226 if ( defined ( $state->{opt}{r} ) )
2227 {
2228 $revFilter = $state->{opt}{r};
3fda8c4c
ML
2229 }
2230
2231 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
2232 my $updater;
2233 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
2234 $updater->update();
2235
4d804c0e
MO
2236 # if no files were specified, we need to work out what files we
2237 # should be providing status on ...
7d90095a 2238 argsfromdir($updater);
3fda8c4c 2239
addf88e4 2240 # foreach file specified on the command line ...
3fda8c4c
ML
2241 foreach my $filename ( @{$state->{args}} )
2242 {
2243 $filename = filecleanup($filename);
2244
2245 my $headmeta = $updater->getmeta($filename);
2246
ab07681f
MO
2247 my ($revisions,$totalrevisions) = $updater->getlog($filename,
2248 $revFilter);
3fda8c4c
ML
2249
2250 next unless ( scalar(@$revisions) );
2251
2252 print "M \n";
2253 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2254 print "M Working file: $filename\n";
ab07681f 2255 print "M head: $headmeta->{revision}\n";
3fda8c4c
ML
2256 print "M branch:\n";
2257 print "M locks: strict\n";
2258 print "M access list:\n";
2259 print "M symbolic names:\n";
2260 print "M keyword substitution: kv\n";
4d804c0e
MO
2261 print "M total revisions: $totalrevisions;\tselected revisions: " .
2262 scalar(@$revisions) . "\n";
3fda8c4c
ML
2263 print "M description:\n";
2264
2265 foreach my $revision ( @$revisions )
2266 {
2267 print "M ----------------------------\n";
ab07681f 2268 print "M revision $revision->{revision}\n";
3fda8c4c 2269 # reformat the date for log output
4d804c0e
MO
2270 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
2271 defined($DATE_LIST->{$2}) )
2272 {
2273 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
2274 $3, $DATE_LIST->{$2}, $1, $4 );
2275 }
c1bc3061 2276 $revision->{author} = cvs_author($revision->{author});
4d804c0e
MO
2277 print "M date: $revision->{modified};" .
2278 " author: $revision->{author}; state: " .
2279 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
2280 "; lines: +2 -3\n";
2281 my $commitmessage;
2282 $commitmessage = $updater->commitmessage($revision->{commithash});
3fda8c4c
ML
2283 $commitmessage =~ s/^/M /mg;
2284 print $commitmessage . "\n";
2285 }
4d804c0e 2286 print "M =======" . ( "=" x 70 ) . "\n";
3fda8c4c
ML
2287 }
2288
2289 print "ok\n";
2290}
2291
2292sub req_annotate
2293{
2294 my ( $cmd, $data ) = @_;
2295
2296 argsplit("annotate");
2297
2298 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
2299 #$log->debug("status state : " . Dumper($state));
2300
2301 # Grab a handle to the SQLite db and do any necessary updates
2302 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2303 $updater->update();
2304
2305 # if no files were specified, we need to work out what files we should be providing annotate on ...
7d90095a 2306 argsfromdir($updater);
3fda8c4c
ML
2307
2308 # we'll need a temporary checkout dir
044182ef 2309 setupWorkTree();
3fda8c4c 2310
044182ef 2311 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
3fda8c4c 2312
addf88e4 2313 # foreach file specified on the command line ...
3fda8c4c
ML
2314 foreach my $filename ( @{$state->{args}} )
2315 {
2316 $filename = filecleanup($filename);
2317
2318 my $meta = $updater->getmeta($filename);
2319
2320 next unless ( $meta->{revision} );
2321
2322 # get all the commits that this file was in
2323 # in dense format -- aka skip dead revisions
2324 my $revisions = $updater->gethistorydense($filename);
2325 my $lastseenin = $revisions->[0][2];
2326
2327 # populate the temporary index based on the latest commit were we saw
2328 # the file -- but do it cheaply without checking out any files
2329 # TODO: if we got a revision from the client, use that instead
2330 # to look up the commithash in sqlite (still good to default to
2331 # the current head as we do now)
d2feb01a 2332 system("git", "read-tree", $lastseenin);
3fda8c4c
ML
2333 unless ($? == 0)
2334 {
044182ef 2335 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
a5e40798 2336 return;
3fda8c4c 2337 }
044182ef 2338 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
3fda8c4c
ML
2339
2340 # do a checkout of the file
d2feb01a 2341 system('git', 'checkout-index', '-f', '-u', $filename);
3fda8c4c 2342 unless ($? == 0) {
a5e40798
JM
2343 print "E error running git-checkout-index -f -u $filename : $!\n";
2344 return;
3fda8c4c
ML
2345 }
2346
2347 $log->info("Annotate $filename");
2348
2349 # Prepare a file with the commits from the linearized
2350 # history that annotate should know about. This prevents
2351 # git-jsannotate telling us about commits we are hiding
2352 # from the client.
2353
044182ef 2354 my $a_hints = "$work->{workDir}/.annotate_hints";
a5e40798
JM
2355 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2356 print "E failed to open '$a_hints' for writing: $!\n";
2357 return;
2358 }
3fda8c4c
ML
2359 for (my $i=0; $i < @$revisions; $i++)
2360 {
2361 print ANNOTATEHINTS $revisions->[$i][2];
2362 if ($i+1 < @$revisions) { # have we got a parent?
2363 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2364 }
2365 print ANNOTATEHINTS "\n";
2366 }
2367
2368 print ANNOTATEHINTS "\n";
a5e40798
JM
2369 close ANNOTATEHINTS
2370 or (print "E failed to write $a_hints: $!\n"), return;
3fda8c4c 2371
d2feb01a 2372 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
a5e40798
JM
2373 if (!open(ANNOTATE, "-|", @cmd)) {
2374 print "E error invoking ". join(' ',@cmd) .": $!\n";
2375 return;
2376 }
3fda8c4c
ML
2377 my $metadata = {};
2378 print "E Annotations for $filename\n";
2379 print "E ***************\n";
2380 while ( <ANNOTATE> )
2381 {
05ea93d6 2382 if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i)
3fda8c4c
ML
2383 {
2384 my $commithash = $1;
2385 my $data = $2;
2386 unless ( defined ( $metadata->{$commithash} ) )
2387 {
2388 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
c1bc3061 2389 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
3fda8c4c
ML
2390 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2391 }
ab07681f 2392 printf("M %-7s (%-8s %10s): %s\n",
3fda8c4c
ML
2393 $metadata->{$commithash}{revision},
2394 $metadata->{$commithash}{author},
2395 $metadata->{$commithash}{modified},
2396 $data
2397 );
2398 } else {
2399 $log->warn("Error in annotate output! LINE: $_");
2400 print "E Annotate error \n";
2401 next;
2402 }
2403 }
2404 close ANNOTATE;
2405 }
2406
2407 # done; get out of the tempdir
df4b3abc 2408 cleanupWorkTree();
3fda8c4c
ML
2409
2410 print "ok\n";
2411
2412}
2413
2414# This method takes the state->{arguments} array and produces two new arrays.
2415# The first is $state->{args} which is everything before the '--' argument, and
2416# the second is $state->{files} which is everything after it.
2417sub argsplit
2418{
3fda8c4c
ML
2419 $state->{args} = [];
2420 $state->{files} = [];
2421 $state->{opt} = {};
2422
1e76b702
FL
2423 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2424
2425 my $type = shift;
2426
3fda8c4c
ML
2427 if ( defined($type) )
2428 {
2429 my $opt = {};
2430 $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" );
2431 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2432 $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" );
61717661 2433 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" );
3fda8c4c
ML
2434 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2435 $opt = { k => 1, m => 1 } if ( $type eq "add" );
2436 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2437 $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" );
2438
2439
2440 while ( scalar ( @{$state->{arguments}} ) > 0 )
2441 {
2442 my $arg = shift @{$state->{arguments}};
2443
2444 next if ( $arg eq "--" );
2445 next unless ( $arg =~ /\S/ );
2446
2447 # if the argument looks like a switch
2448 if ( $arg =~ /^-(\w)(.*)/ )
2449 {
2450 # if it's a switch that takes an argument
2451 if ( $opt->{$1} )
2452 {
2453 # If this switch has already been provided
2454 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2455 {
2456 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2457 if ( length($2) > 0 )
2458 {
2459 push @{$state->{opt}{$1}},$2;
2460 } else {
2461 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2462 }
2463 } else {
2464 # if there's extra data in the arg, use that as the argument for the switch
2465 if ( length($2) > 0 )
2466 {
2467 $state->{opt}{$1} = $2;
2468 } else {
2469 $state->{opt}{$1} = shift @{$state->{arguments}};
2470 }
2471 }
2472 } else {
2473 $state->{opt}{$1} = undef;
2474 }
2475 }
2476 else
2477 {
2478 push @{$state->{args}}, $arg;
2479 }
2480 }
2481 }
2482 else
2483 {
2484 my $mode = 0;
2485
2486 foreach my $value ( @{$state->{arguments}} )
2487 {
2488 if ( $value eq "--" )
2489 {
2490 $mode++;
2491 next;
2492 }
2493 push @{$state->{args}}, $value if ( $mode == 0 );
2494 push @{$state->{files}}, $value if ( $mode == 1 );
2495 }
2496 }
2497}
2498
d66e8f8c
MO
2499# Used by argsfromdir
2500sub expandArg
3fda8c4c 2501{
d66e8f8c 2502 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
3fda8c4c 2503
d66e8f8c 2504 my $fullPath = filecleanup($path);
7d90095a 2505
d66e8f8c
MO
2506 # Is it a directory?
2507 if( defined($state->{dirMap}{$fullPath}) ||
2508 defined($state->{dirMap}{"$fullPath/"}) )
2509 {
2510 # It is a directory in the user's sandbox.
2511 $isDir=1;
7d90095a 2512
d66e8f8c
MO
2513 if(defined($state->{entries}{$fullPath}))
2514 {
2515 $log->fatal("Inconsistent file/dir type");
2516 die "Inconsistent file/dir type";
2517 }
2518 }
2519 elsif(defined($state->{entries}{$fullPath}))
2520 {
2521 # It is a file in the user's sandbox.
2522 $isDir=0;
2523 }
2524 my($revDirMap,$otherRevDirMap);
2525 if(!defined($isDir) || $isDir)
2526 {
2527 # Resolve version tree for sticky tag:
2528 # (for now we only want list of files for the version, not
2529 # particular versions of those files: assume it is a directory
2530 # for the moment; ignore Entry's stick tag)
2531
2532 # Order of precedence of sticky tags:
2533 # -A [head]
2534 # -r /tag/
2535 # [file entry sticky tag, but that is only relevant to files]
2536 # [the tag specified in dir req_Sticky]
2537 # [the tag specified in a parent dir req_Sticky]
2538 # [head]
2539 # Also, -r may appear twice (for diff).
2540 #
2541 # FUTURE: When/if -j (merges) are supported, we also
2542 # need to add relevant files from one or two
2543 # versions specified with -j.
2544
2545 if(exists($state->{opt}{A}))
2546 {
2547 $revDirMap=$updater->getRevisionDirMap();
2548 }
2549 elsif( defined($state->{opt}{r}) and
2550 ref $state->{opt}{r} eq "ARRAY" )
2551 {
2552 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
2553 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
2554 }
2555 elsif(defined($state->{opt}{r}))
2556 {
2557 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
2558 }
2559 else
2560 {
2561 my($sticky)=getDirStickyInfo($fullPath);
2562 $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
2563 }
0a7a9a12 2564
d66e8f8c
MO
2565 # Is it a directory?
2566 if( defined($revDirMap->{$fullPath}) ||
2567 defined($otherRevDirMap->{$fullPath}) )
2568 {
2569 $isDir=1;
2570 }
0a7a9a12
JS
2571 }
2572
d66e8f8c
MO
2573 # What to do with it?
2574 if(!$isDir)
82000d74 2575 {
d66e8f8c
MO
2576 $outNameMap->{$fullPath}=1;
2577 }
2578 else
2579 {
2580 $outDirMap->{$fullPath}=1;
3fda8c4c 2581
d66e8f8c
MO
2582 if(defined($revDirMap->{$fullPath}))
2583 {
2584 addDirMapFiles($updater,$outNameMap,$outDirMap,
2585 $revDirMap->{$fullPath});
2586 }
2587 if( defined($otherRevDirMap) &&
2588 defined($otherRevDirMap->{$fullPath}) )
82000d74 2589 {
d66e8f8c
MO
2590 addDirMapFiles($updater,$outNameMap,$outDirMap,
2591 $otherRevDirMap->{$fullPath});
82000d74 2592 }
d66e8f8c
MO
2593 }
2594}
82000d74 2595
d66e8f8c
MO
2596# Used by argsfromdir
2597# Add entries from dirMap to outNameMap. Also recurse into entries
2598# that are subdirectories.
2599sub addDirMapFiles
2600{
2601 my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
82000d74 2602
d66e8f8c
MO
2603 my($fullName);
2604 foreach $fullName (keys(%$dirMap))
2605 {
2606 my $cleanName=$fullName;
2607 if(defined($state->{prependdir}))
2608 {
2609 if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2610 {
2611 $log->fatal("internal error stripping prependdir");
2612 die "internal error stripping prependdir";
2613 }
2614 }
82000d74 2615
d66e8f8c
MO
2616 if($dirMap->{$fullName} eq "F")
2617 {
2618 $outNameMap->{$cleanName}=1;
2619 }
2620 elsif($dirMap->{$fullName} eq "D")
2621 {
2622 if(!$state->{opt}{l})
2623 {
2624 expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
2625 }
2626 }
2627 else
82000d74 2628 {
d66e8f8c
MO
2629 $log->fatal("internal error in addDirMapFiles");
2630 die "internal error in addDirMapFiles";
82000d74 2631 }
3fda8c4c
ML
2632 }
2633}
2634
d66e8f8c
MO
2635# This method replaces $state->{args} with a directory-expanded
2636# list of all relevant filenames (recursively unless -d), based
2637# on $state->{entries}, and the "current" list of files in
2638# each directory. "Current" files as determined by
2639# either the requested (-r/-A) or "req_Sticky" version of
2640# that directory.
2641# Both the input args and the new output args are relative
2642# to the cvs-client's CWD, although some of the internal
2643# computations are relative to the top of the project.
2644sub argsfromdir
2645{
2646 my $updater = shift;
2647
2648 # Notes about requirements for specific callers:
2649 # update # "standard" case (entries; a single -r/-A/default; -l)
2650 # # Special case: -d for create missing directories.
2651 # diff # 0 or 1 -r's: "standard" case.
2652 # # 2 -r's: We could ignore entries (just use the two -r's),
2653 # # but it doesn't really matter.
2654 # annotate # "standard" case
2655 # log # Punting: log -r has a more complex non-"standard"
2656 # # meaning, and we don't currently try to support log'ing
2657 # # branches at all (need a lot of work to
2658 # # support CVS-consistent branch relative version
2659 # # numbering).
2660#HERE: But we still want to expand directories. Maybe we should
2661# essentially force "-A".
2662 # status # "standard", except that -r/-A/default are not possible.
2663 # # Mostly only used to expand entries only)
2664 #
2665 # Don't use argsfromdir at all:
2666 # add # Explicit arguments required. Directory args imply add
2667 # # the directory itself, not the files in it.
2668 # co # Obtain list directly.
2669 # remove # HERE: TEST: MAYBE client does the recursion for us,
2670 # # since it only makes sense to remove stuff already in
527d4a63 2671 # # the sandbox?
d66e8f8c
MO
2672 # ci # HERE: Similar to remove...
2673 # # Don't try to implement the confusing/weird
2674 # # ci -r bug er.."feature".
2675
2676 if(scalar(@{$state->{args}})==0)
2677 {
2678 $state->{args} = [ "." ];
2679 }
2680 my %allArgs;
2681 my %allDirs;
2682 for my $file (@{$state->{args}})
2683 {
2684 expandArg($updater,\%allArgs,\%allDirs,$file);
2685 }
2686
2687 # Include any entries from sandbox. Generally client won't
2688 # send entries that shouldn't be used.
2689 foreach my $file (keys %{$state->{entries}})
2690 {
2691 $allArgs{remove_prependdir($file)} = 1;
2692 }
2693
2694 $state->{dirArgs} = \%allDirs;
2695 $state->{args} = [
2696 sort {
2697 # Sort priority: by directory depth, then actual file name:
2698 my @piecesA=split('/',$a);
2699 my @piecesB=split('/',$b);
2700
2701 my $count=scalar(@piecesA);
2702 my $tmp=scalar(@piecesB);
2703 return $count<=>$tmp if($count!=$tmp);
2704
2705 for($tmp=0;$tmp<$count;$tmp++)
2706 {
2707 if($piecesA[$tmp] ne $piecesB[$tmp])
2708 {
2709 return $piecesA[$tmp] cmp $piecesB[$tmp]
2710 }
2711 }
2712 return 0;
2713 } keys(%allArgs) ];
2714}
eb5dcb2c
MO
2715
2716## look up directory sticky tag, of either fullPath or a parent:
2717sub getDirStickyInfo
2718{
2719 my($fullPath)=@_;
2720
2721 $fullPath=~s%/+$%%;
2722 while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
2723 {
2724 $fullPath=~s%/?[^/]*$%%;
2725 }
2726
2727 if( !defined($state->{dirMap}{"$fullPath/"}) &&
2728 ( $fullPath eq "" ||
2729 $fullPath eq "." ) )
2730 {
2731 return $state->{dirMap}{""}{stickyInfo};
2732 }
2733 else
2734 {
2735 return $state->{dirMap}{"$fullPath/"}{stickyInfo};
2736 }
2737}
2738
2739# Resolve precedence of various ways of specifying which version of
2740# a file you want. Returns undef (for default head), or a ref to a hash
2741# that contains "tag" and/or "date" keys.
2742sub resolveStickyInfo
2743{
2744 my($filename,$stickyTag,$stickyDate,$reset) = @_;
2745
2746 # Order of precedence of sticky tags:
2747 # -A [head]
2748 # -r /tag/
2749 # [file entry sticky tag]
2750 # [the tag specified in dir req_Sticky]
2751 # [the tag specified in a parent dir req_Sticky]
2752 # [head]
2753
2754 my $result;
2755 if($reset)
2756 {
2757 # $result=undef;
2758 }
2759 elsif( defined($stickyTag) && $stickyTag ne "" )
2760 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
2761 {
2762 $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
2763
2764 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
2765 # similar to an entry line's sticky date, without the D prefix.
2766 # It sometimes (always?) arrives as something more like
2767 # '10 Apr 2011 04:46:57 -0000'...
2768 # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
2769 }
2770 elsif( defined($state->{entries}{$filename}) &&
2771 defined($state->{entries}{$filename}{tag_or_date}) &&
2772 $state->{entries}{$filename}{tag_or_date} ne "" )
2773 {
2774 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
2775 if($tagOrDate=~/^T([^ ]+)\s*$/)
2776 {
2777 $result = { 'tag' => $1 };
2778 }
2779 elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2780 {
2781 $result= { 'date' => $1 };
2782 }
2783 else
2784 {
2785 die "Unknown tag_or_date format\n";
2786 }
2787 }
2788 else
2789 {
2790 $result=getDirStickyInfo($filename);
2791 }
2792
2793 return $result;
2794}
2795
2796# Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into
2797# a form appropriate for the sticky tag field of an Entries
2798# line (field index 5, 0-based).
2799sub getStickyTagOrDate
2800{
2801 my($stickyInfo)=@_;
2802
2803 my $result;
2804 if(defined($stickyInfo) && defined($stickyInfo->{tag}))
2805 {
2806 $result="T$stickyInfo->{tag}";
2807 }
2808 # TODO: When/if we actually pick versions by {date} properly,
2809 # also handle it here:
2810 # "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07").
2811 else
2812 {
2813 $result="";
2814 }
2815
2816 return $result;
2817}
2818
3fda8c4c
ML
2819# This method cleans up the $state variable after a command that uses arguments has run
2820sub statecleanup
2821{
2822 $state->{files} = [];
d66e8f8c 2823 $state->{dirArgs} = {};
3fda8c4c
ML
2824 $state->{args} = [];
2825 $state->{arguments} = [];
2826 $state->{entries} = {};
eb5dcb2c 2827 $state->{dirMap} = {};
3fda8c4c
ML
2828}
2829
ab07681f 2830# Return working directory CVS revision "1.X" out
832c0e5e 2831# of the working directory "entries" state, for the given filename.
ab07681f 2832# This is prefixed with a dash if the file is scheduled for removal
196e48f4 2833# when it is committed.
3fda8c4c
ML
2834sub revparse
2835{
2836 my $filename = shift;
2837
ab07681f 2838 return $state->{entries}{$filename}{revision};
3fda8c4c
ML
2839}
2840
e78f69a3
DD
2841# This method takes a file hash and does a CVS "file transfer". Its
2842# exact behaviour depends on a second, optional hash table argument:
2843# - If $options->{targetfile}, dump the contents to that file;
2844# - If $options->{print}, use M/MT to transmit the contents one line
2845# at a time;
2846# - Otherwise, transmit the size of the file, followed by the file
2847# contents.
3fda8c4c
ML
2848sub transmitfile
2849{
2850 my $filehash = shift;
e78f69a3 2851 my $options = shift;
3fda8c4c
ML
2852
2853 if ( defined ( $filehash ) and $filehash eq "deleted" )
2854 {
2855 $log->warn("filehash is 'deleted'");
2856 return;
2857 }
2858
05ea93d6 2859 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
3fda8c4c 2860
27dd7387 2861 my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
3fda8c4c
ML
2862 chomp $type;
2863
2864 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2865
27dd7387 2866 my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
3fda8c4c
ML
2867 chomp $size;
2868
2869 $log->debug("transmitfile($filehash) size=$size, type=$type");
2870
d2feb01a 2871 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
3fda8c4c 2872 {
e78f69a3 2873 if ( defined ( $options->{targetfile} ) )
3fda8c4c 2874 {
e78f69a3 2875 my $targetfile = $options->{targetfile};
3fda8c4c
ML
2876 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2877 print NEWFILE $_ while ( <$fh> );
a5e40798 2878 close NEWFILE or die("Failed to write '$targetfile': $!");
e78f69a3
DD
2879 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2880 while ( <$fh> ) {
2881 if( /\n\z/ ) {
2882 print 'M ', $_;
2883 } else {
2884 print 'MT text ', $_, "\n";
2885 }
2886 }
3fda8c4c
ML
2887 } else {
2888 print "$size\n";
2889 print while ( <$fh> );
2890 }
a5e40798 2891 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
3fda8c4c
ML
2892 } else {
2893 die("Couldn't execute git-cat-file");
2894 }
2895}
2896
2897# This method takes a file name, and returns ( $dirpart, $filepart ) which
5348b6e7 2898# refers to the directory portion and the file portion of the filename
3fda8c4c
ML
2899# respectively
2900sub filenamesplit
2901{
2902 my $filename = shift;
7d90095a 2903 my $fixforlocaldir = shift;
3fda8c4c
ML
2904
2905 my ( $filepart, $dirpart ) = ( $filename, "." );
2906 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2907 $dirpart .= "/";
2908
7d90095a
MS
2909 if ( $fixforlocaldir )
2910 {
2911 $dirpart =~ s/^$state->{prependdir}//;
2912 }
2913
3fda8c4c
ML
2914 return ( $filepart, $dirpart );
2915}
2916
1899cbc5 2917# Cleanup various junk in filename (try to canonicalize it), and
41ccfdd9 2918# add prependdir to accommodate running CVS client from a
1899cbc5 2919# subdirectory (so the output is relative to top directory of the project).
3fda8c4c
ML
2920sub filecleanup
2921{
2922 my $filename = shift;
2923
2924 return undef unless(defined($filename));
2925 if ( $filename =~ /^\// )
2926 {
2927 print "E absolute filenames '$filename' not supported by server\n";
2928 return undef;
2929 }
2930
1899cbc5
MO
2931 if($filename eq ".")
2932 {
2933 $filename="";
2934 }
3fda8c4c 2935 $filename =~ s/^\.\///g;
1899cbc5 2936 $filename =~ s%/+%/%g;
82000d74 2937 $filename = $state->{prependdir} . $filename;
1899cbc5 2938 $filename =~ s%/$%%;
3fda8c4c
ML
2939 return $filename;
2940}
2941
832c0e5e 2942# Remove prependdir from the path, so that it is relative to the directory
1899cbc5
MO
2943# the CVS client was started from, rather than the top of the project.
2944# Essentially the inverse of filecleanup().
2945sub remove_prependdir
2946{
2947 my($path) = @_;
2948 if(defined($state->{prependdir}) && $state->{prependdir} ne "")
2949 {
2950 my($pre)=$state->{prependdir};
2951 $pre=~s%/$%%;
2952 if(!($path=~s%^\Q$pre\E/?%%))
2953 {
2954 $log->fatal("internal error missing prependdir");
2955 die("internal error missing prependdir");
2956 }
2957 }
2958 return $path;
2959}
2960
044182ef
MO
2961sub validateGitDir
2962{
2963 if( !defined($state->{CVSROOT}) )
2964 {
2965 print "error 1 CVSROOT not specified\n";
2966 cleanupWorkTree();
2967 exit;
2968 }
2969 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2970 {
2971 print "error 1 Internally inconsistent CVSROOT\n";
2972 cleanupWorkTree();
2973 exit;
2974 }
2975}
2976
2977# Setup working directory in a work tree with the requested version
2978# loaded in the index.
2979sub setupWorkTree
2980{
2981 my ($ver) = @_;
2982
2983 validateGitDir();
2984
2985 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2986 defined($work->{tmpDir}) )
2987 {
2988 $log->warn("Bad work tree state management");
2989 print "error 1 Internal setup multiple work trees without cleanup\n";
2990 cleanupWorkTree();
2991 exit;
2992 }
2993
2994 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2995
2996 if( !defined($work->{index}) )
2997 {
2998 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2999 }
3000
3001 chdir $work->{workDir} or
3002 die "Unable to chdir to $work->{workDir}\n";
3003
3004 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3005
3006 $ENV{GIT_WORK_TREE} = ".";
3007 $ENV{GIT_INDEX_FILE} = $work->{index};
3008 $work->{state} = 2;
3009
3010 if($ver)
3011 {
3012 system("git","read-tree",$ver);
3013 unless ($? == 0)
3014 {
3015 $log->warn("Error running git-read-tree");
3016 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3017 }
3018 }
3019 # else # req_annotate reads tree for each file
3020}
3021
3022# Ensure current directory is in some kind of working directory,
3023# with a recent version loaded in the index.
3024sub ensureWorkTree
3025{
3026 if( defined($work->{tmpDir}) )
3027 {
3028 $log->warn("Bad work tree state management [ensureWorkTree()]");
3029 print "error 1 Internal setup multiple dirs without cleanup\n";
3030 cleanupWorkTree();
3031 exit;
3032 }
3033 if( $work->{state} )
3034 {
3035 return;
3036 }
3037
3038 validateGitDir();
3039
3040 if( !defined($work->{emptyDir}) )
3041 {
3042 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
3043 }
3044 chdir $work->{emptyDir} or
3045 die "Unable to chdir to $work->{emptyDir}\n";
3046
27dd7387 3047 my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}");
044182ef 3048 chomp $ver;
05ea93d6 3049 if ($ver !~ /^[0-9a-f]{$state->{hexsz}}$/)
044182ef
MO
3050 {
3051 $log->warn("Error from git show-ref -s refs/head$state->{module}");
3052 print "error 1 cannot find the current HEAD of module";
3053 cleanupWorkTree();
3054 exit;
3055 }
3056
3057 if( !defined($work->{index}) )
3058 {
3059 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3060 }
3061
3062 $ENV{GIT_WORK_TREE} = ".";
3063 $ENV{GIT_INDEX_FILE} = $work->{index};
3064 $work->{state} = 1;
3065
3066 system("git","read-tree",$ver);
3067 unless ($? == 0)
3068 {
3069 die "Error running git-read-tree $ver $!\n";
3070 }
3071}
3072
3073# Cleanup working directory that is not needed any longer.
3074sub cleanupWorkTree
3075{
3076 if( ! $work->{state} )
3077 {
3078 return;
3079 }
3080
3081 chdir "/" or die "Unable to chdir '/'\n";
3082
3083 if( defined($work->{workDir}) )
3084 {
3085 rmtree( $work->{workDir} );
3086 undef $work->{workDir};
3087 }
3088 undef $work->{state};
3089}
3090
3091# Setup a temporary directory (not a working tree), typically for
3092# merging dirty state as in req_update.
3093sub setupTmpDir
3094{
3095 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
3096 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
3097
3098 return $work->{tmpDir};
3099}
3100
3101# Clean up a previously setupTmpDir. Restore previous work tree if
3102# appropriate.
3103sub cleanupTmpDir
3104{
3105 if ( !defined($work->{tmpDir}) )
3106 {
3107 $log->warn("cleanup tmpdir that has not been setup");
3108 die "Cleanup tmpDir that has not been setup\n";
3109 }
3110 if( defined($work->{state}) )
3111 {
3112 if( $work->{state} == 1 )
3113 {
3114 chdir $work->{emptyDir} or
3115 die "Unable to chdir to $work->{emptyDir}\n";
3116 }
3117 elsif( $work->{state} == 2 )
3118 {
3119 chdir $work->{workDir} or
3120 die "Unable to chdir to $work->{emptyDir}\n";
3121 }
3122 else
3123 {
3124 $log->warn("Inconsistent work dir state");
3125 die "Inconsistent work dir state\n";
3126 }
3127 }
3128 else
3129 {
3130 chdir "/" or die "Unable to chdir '/'\n";
3131 }
3132}
3133
8538e876
AP
3134# Given a path, this function returns a string containing the kopts
3135# that should go into that path's Entries line. For example, a binary
3136# file should get -kb.
3137sub kopts_from_path
3138{
90948a42 3139 my ($path, $srcType, $name) = @_;
8538e876 3140
8a06a632
MO
3141 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
3142 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
3143 {
5ec3e670
EB
3144 my ($val) = check_attr( "text", $path );
3145 if ( $val eq "unspecified" )
8a06a632 3146 {
5ec3e670 3147 $val = check_attr( "crlf", $path );
8a06a632 3148 }
5ec3e670 3149 if ( $val eq "unset" )
8a06a632
MO
3150 {
3151 return "-kb"
3152 }
5ec3e670
EB
3153 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
3154 $val eq "set" || $val eq "input" )
3155 {
3156 return "";
3157 }
8a06a632
MO
3158 else
3159 {
3160 $log->info("Unrecognized check_attr crlf $path : $val");
3161 }
3162 }
8538e876 3163
90948a42 3164 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
8538e876 3165 {
90948a42
MO
3166 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
3167 {
3168 return "-kb";
3169 }
3170 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
3171 {
39b6a4bd 3172 if( is_binary($srcType,$name) )
90948a42 3173 {
39b6a4bd
MO
3174 $log->debug("... as binary");
3175 return "-kb";
90948a42
MO
3176 }
3177 else
3178 {
39b6a4bd 3179 $log->debug("... as text");
90948a42
MO
3180 }
3181 }
8538e876 3182 }
90948a42
MO
3183 # Return "" to give no special treatment to any path
3184 return "";
8538e876
AP
3185}
3186
8a06a632
MO
3187sub check_attr
3188{
3189 my ($attr,$path) = @_;
3190 ensureWorkTree();
3191 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3192 {
3193 my $val = <$fh>;
3194 close $fh;
3195 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3196 return $val;
3197 }
3198 else
3199 {
3200 return undef;
3201 }
3202}
3203
90948a42
MO
3204# This should have the same heuristics as convert.c:is_binary() and related.
3205# Note that the bare CR test is done by callers in convert.c.
3206sub is_binary
3207{
3208 my ($srcType,$name) = @_;
3209 $log->debug("is_binary($srcType,$name)");
3210
3211 # Minimize amount of interpreted code run in the inner per-character
3212 # loop for large files, by totalling each character value and
3213 # then analyzing the totals.
3214 my @counts;
3215 my $i;
3216 for($i=0;$i<256;$i++)
3217 {
3218 $counts[$i]=0;
3219 }
3220
3221 my $fh = open_blob_or_die($srcType,$name);
3222 my $line;
3223 while( defined($line=<$fh>) )
3224 {
3225 # Any '\0' and bare CR are considered binary.
3226 if( $line =~ /\0|(\r[^\n])/ )
3227 {
3228 close($fh);
3229 return 1;
3230 }
3231
3232 # Count up each character in the line:
3233 my $len=length($line);
3234 for($i=0;$i<$len;$i++)
3235 {
3236 $counts[ord(substr($line,$i,1))]++;
3237 }
3238 }
3239 close $fh;
3240
3241 # Don't count CR and LF as either printable/nonprintable
3242 $counts[ord("\n")]=0;
3243 $counts[ord("\r")]=0;
3244
3245 # Categorize individual character count into printable and nonprintable:
3246 my $printable=0;
3247 my $nonprintable=0;
3248 for($i=0;$i<256;$i++)
3249 {
3250 if( $i < 32 &&
3251 $i != ord("\b") &&
3252 $i != ord("\t") &&
3253 $i != 033 && # ESC
3254 $i != 014 ) # FF
3255 {
3256 $nonprintable+=$counts[$i];
3257 }
3258 elsif( $i==127 ) # DEL
3259 {
3260 $nonprintable+=$counts[$i];
3261 }
3262 else
3263 {
3264 $printable+=$counts[$i];
3265 }
3266 }
3267
3268 return ($printable >> 7) < $nonprintable;
3269}
3270
3271# Returns open file handle. Possible invocations:
3272# - open_blob_or_die("file",$filename);
3273# - open_blob_or_die("sha1",$filehash);
3274sub open_blob_or_die
3275{
3276 my ($srcType,$name) = @_;
3277 my ($fh);
3278 if( $srcType eq "file" )
3279 {
3280 if( !open $fh,"<",$name )
3281 {
3282 $log->warn("Unable to open file $name: $!");
3283 die "Unable to open file $name: $!\n";
3284 }
3285 }
39b6a4bd 3286 elsif( $srcType eq "sha1" )
90948a42 3287 {
05ea93d6 3288 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ )
90948a42
MO
3289 {
3290 $log->warn("Need filehash");
3291 die "Need filehash\n";
3292 }
3293
27dd7387 3294 my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
90948a42
MO
3295 chomp $type;
3296
3297 unless ( defined ( $type ) and $type eq "blob" )
3298 {
3299 $log->warn("Invalid type '$type' for '$name'");
3300 die ( "Invalid type '$type' (expected 'blob')" )
3301 }
3302
27dd7387 3303 my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
90948a42
MO
3304 chomp $size;
3305
3306 $log->debug("open_blob_or_die($name) size=$size, type=$type");
3307
3308 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3309 {
3310 $log->warn("Unable to open sha1 $name");
3311 die "Unable to open sha1 $name\n";
3312 }
3313 }
3314 else
3315 {
3316 $log->warn("Unknown type of blob source: $srcType");
3317 die "Unknown type of blob source: $srcType\n";
3318 }
3319 return $fh;
3320}
3321
d500a1ee
FE
3322# Generate a CVS author name from Git author information, by taking the local
3323# part of the email address and replacing characters not in the Portable
3324# Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
3325# Login names are Unix login names, which should be restricted to this
3326# character set.
c1bc3061
DD
3327sub cvs_author
3328{
3329 my $author_line = shift;
d500a1ee
FE
3330 (my $author) = $author_line =~ /<([^@>]*)/;
3331
3332 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3333 $author =~ s/^-/_/;
c1bc3061
DD
3334
3335 $author;
3336}
3337
031a027a
ÆAB
3338
3339sub descramble
3340{
3341 # This table is from src/scramble.c in the CVS source
3342 my @SHIFTS = (
3343 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
3344 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
3345 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
3346 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
3347 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
3348 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
3349 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
3350 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
3351 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
3352 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
3353 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
3354 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
3355 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
3356 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
3357 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
3358 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
3359 );
3360 my ($str) = @_;
3361
fce338a5 3362 # This should never happen, the same password format (A) has been
031a027a 3363 # used by CVS since the beginning of time
1f0eb513
ÆAB
3364 {
3365 my $fmt = substr($str, 0, 1);
3366 die "invalid password format `$fmt'" unless $fmt eq 'A';
3367 }
031a027a
ÆAB
3368
3369 my @str = unpack "C*", substr($str, 1);
3370 my $ret = join '', map { chr $SHIFTS[$_] } @str;
3371 return $ret;
3372}
3373
61717661
MO
3374# Test if the (deep) values of two references to a hash are the same.
3375sub refHashEqual
3376{
3377 my($v1,$v2) = @_;
3378
3379 my $out;
3380 if(!defined($v1))
3381 {
3382 if(!defined($v2))
3383 {
3384 $out=1;
3385 }
3386 }
3387 elsif( !defined($v2) ||
3388 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3389 {
3390 # $out=undef;
3391 }
3392 else
3393 {
3394 $out=1;
3395
3396 my $key;
3397 foreach $key (keys(%{$v1}))
3398 {
3399 if( !exists($v2->{$key}) ||
3400 defined($v1->{$key}) ne defined($v2->{$key}) ||
3401 ( defined($v1->{$key}) &&
3402 $v1->{$key} ne $v2->{$key} ) )
3403 {
3404 $out=undef;
3405 last;
3406 }
3407 }
3408 }
3409
3410 return $out;
3411}
3412
fce13af5
JH
3413# an alternative to `command` that allows input to be passed as an array
3414# to work around shell problems with weird characters in arguments
3415
3416sub safe_pipe_capture {
3417
3418 my @output;
3419
3420 if (my $pid = open my $child, '-|') {
3421 @output = (<$child>);
3422 close $child or die join(' ',@_).": $! $?";
3423 } else {
3424 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3425 }
3426 return wantarray ? @output : join('',@output);
3427}
3428
031a027a 3429
3fda8c4c
ML
3430package GITCVS::log;
3431
3432####
3433#### Copyright The Open University UK - 2006.
3434####
3435#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 3436#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
3437####
3438####
3439
3440use strict;
3441use warnings;
3442
3443=head1 NAME
3444
3445GITCVS::log
3446
3447=head1 DESCRIPTION
3448
3449This module provides very crude logging with a similar interface to
3450Log::Log4perl
3451
3452=head1 METHODS
3453
3454=cut
3455
3456=head2 new
3457
3458Creates a new log object, optionally you can specify a filename here to
5348b6e7 3459indicate the file to log to. If no log file is specified, you can specify one
3fda8c4c
ML
3460later with method setfile, or indicate you no longer want logging with method
3461nofile.
3462
3463Until one of these methods is called, all log calls will buffer messages ready
3464to write out.
3465
3466=cut
3467sub new
3468{
3469 my $class = shift;
3470 my $filename = shift;
3471
3472 my $self = {};
3473
3474 bless $self, $class;
3475
3476 if ( defined ( $filename ) )
3477 {
3478 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3479 }
3480
3481 return $self;
3482}
3483
3484=head2 setfile
3485
3486This methods takes a filename, and attempts to open that file as the log file.
3487If successful, all buffered data is written out to the file, and any further
3488logging is written directly to the file.
3489
3490=cut
3491sub setfile
3492{
3493 my $self = shift;
3494 my $filename = shift;
3495
3496 if ( defined ( $filename ) )
3497 {
3498 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3499 }
3500
3501 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3502
3503 while ( my $line = shift @{$self->{buffer}} )
3504 {
3505 print {$self->{fh}} $line;
3506 }
3507}
3508
3509=head2 nofile
3510
3511This method indicates no logging is going to be used. It flushes any entries in
3512the internal buffer, and sets a flag to ensure no further data is put there.
3513
3514=cut
3515sub nofile
3516{
3517 my $self = shift;
3518
3519 $self->{nolog} = 1;
3520
3521 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3522
3523 $self->{buffer} = [];
3524}
3525
3526=head2 _logopen
3527
3528Internal method. Returns true if the log file is open, false otherwise.
3529
3530=cut
3531sub _logopen
3532{
3533 my $self = shift;
3534
3535 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
3536 return 0;
3537}
3538
3539=head2 debug info warn fatal
3540
3541These four methods are wrappers to _log. They provide the actual interface for
3542logging data.
3543
3544=cut
3545sub debug { my $self = shift; $self->_log("debug", @_); }
3546sub info { my $self = shift; $self->_log("info" , @_); }
3547sub warn { my $self = shift; $self->_log("warn" , @_); }
3548sub fatal { my $self = shift; $self->_log("fatal", @_); }
3549
3550=head2 _log
3551
3552This is an internal method called by the logging functions. It generates a
3553timestamp and pushes the logged line either to file, or internal buffer.
3554
3555=cut
3556sub _log
3557{
3558 my $self = shift;
3559 my $level = shift;
3560
3561 return if ( $self->{nolog} );
3562
3563 my @time = localtime;
3564 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
3565 $time[5] + 1900,
3566 $time[4] + 1,
3567 $time[3],
3568 $time[2],
3569 $time[1],
3570 $time[0],
3571 uc $level,
3572 );
3573
3574 if ( $self->_logopen )
3575 {
3576 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
3577 } else {
3578 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
3579 }
3580}
3581
3582=head2 DESTROY
3583
3584This method simply closes the file handle if one is open
3585
3586=cut
3587sub DESTROY
3588{
3589 my $self = shift;
3590
3591 if ( $self->_logopen )
3592 {
3593 close $self->{fh};
3594 }
3595}
3596
3597package GITCVS::updater;
3598
3599####
3600#### Copyright The Open University UK - 2006.
3601####
3602#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 3603#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
3604####
3605####
3606
3607use strict;
3608use warnings;
3609use DBI;
3610
3611=head1 METHODS
3612
3613=cut
3614
3615=head2 new
3616
3617=cut
3618sub new
3619{
3620 my $class = shift;
3621 my $config = shift;
3622 my $module = shift;
3623 my $log = shift;
3624
3625 die "Need to specify a git repository" unless ( defined($config) and -d $config );
3626 die "Need to specify a module" unless ( defined($module) );
3627
3628 $class = ref($class) || $class;
3629
3630 my $self = {};
3631
3632 bless $self, $class;
3633
6aeeffd1
JE
3634 $self->{valid_tables} = {'revision' => 1,
3635 'revision_ix1' => 1,
3636 'revision_ix2' => 1,
3637 'head' => 1,
3638 'head_ix1' => 1,
3639 'properties' => 1,
3640 'commitmsgs' => 1};
3641
3fda8c4c 3642 $self->{module} = $module;
3fda8c4c
ML
3643 $self->{git_path} = $config . "/";
3644
3645 $self->{log} = $log;
3646
3647 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
3648
658b57ad
MO
3649 # Stores full sha1's for various branch/tag names, abbreviations, etc:
3650 $self->{commitRefCache} = {};
3651
eb1780d4 3652 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
473937ed 3653 $cfg->{gitcvs}{dbdriver} || "SQLite";
eb1780d4
FL
3654 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
3655 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
3656 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
3657 $cfg->{gitcvs}{dbuser} || "";
3658 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
3659 $cfg->{gitcvs}{dbpass} || "";
6aeeffd1
JE
3660 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
3661 $cfg->{gitcvs}{dbtablenameprefix} || "";
eb1780d4
FL
3662 my %mapping = ( m => $module,
3663 a => $state->{method},
3664 u => getlogin || getpwuid($<) || $<,
3665 G => $self->{git_path},
3666 g => mangle_dirname($self->{git_path}),
3667 );
3668 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
3669 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
6aeeffd1
JE
3670 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
3671 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
eb1780d4 3672
473937ed
FL
3673 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
3674 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
3675 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
eb1780d4
FL
3676 $self->{dbuser},
3677 $self->{dbpass});
920a449a 3678 die "Error connecting to database\n" unless defined $self->{dbh};
3fda8c4c
ML
3679
3680 $self->{tables} = {};
0cf611a3 3681 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3fda8c4c 3682 {
3fda8c4c
ML
3683 $self->{tables}{$table} = 1;
3684 }
3685
3686 # Construct the revision table if required
196e48f4
MO
3687 # The revision table stores an entry for each file, each time that file
3688 # changes.
3689 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3690 # This is not sufficient to support "-r {commithash}" for any
3691 # files except files that were modified by that commit (also,
3692 # some places in the code ignore/effectively strip out -r in
3693 # some cases, before it gets passed to getmeta()).
3694 # The "filehash" field typically has a git blob hash, but can also
3695 # be set to "dead" to indicate that the given version of the file
3696 # should not exist in the sandbox.
6aeeffd1 3697 unless ( $self->{tables}{$self->tablename("revision")} )
3fda8c4c 3698 {
6aeeffd1
JE
3699 my $tablename = $self->tablename("revision");
3700 my $ix1name = $self->tablename("revision_ix1");
3701 my $ix2name = $self->tablename("revision_ix2");
3fda8c4c 3702 $self->{dbh}->do("
6aeeffd1 3703 CREATE TABLE $tablename (
3fda8c4c
ML
3704 name TEXT NOT NULL,
3705 revision INTEGER NOT NULL,
3706 filehash TEXT NOT NULL,
3707 commithash TEXT NOT NULL,
3708 author TEXT NOT NULL,
3709 modified TEXT NOT NULL,
3710 mode TEXT NOT NULL
3711 )
3712 ");
178e015c 3713 $self->{dbh}->do("
6aeeffd1
JE
3714 CREATE INDEX $ix1name
3715 ON $tablename (name,revision)
178e015c
SP
3716 ");
3717 $self->{dbh}->do("
6aeeffd1
JE
3718 CREATE INDEX $ix2name
3719 ON $tablename (name,commithash)
178e015c 3720 ");
3fda8c4c
ML
3721 }
3722
178e015c 3723 # Construct the head table if required
196e48f4
MO
3724 # The head table (along with the "last_commit" entry in the property
3725 # table) is the persisted working state of the "sub update" subroutine.
3726 # All of it's data is read entirely first, and completely recreated
3727 # last, every time "sub update" runs.
3728 # This is also used by "sub getmeta" when it is asked for the latest
3729 # version of a file (as opposed to some specific version).
3730 # Another way of thinking about it is as a single slice out of
3731 # "revisions", giving just the most recent revision information for
3732 # each file.
6aeeffd1 3733 unless ( $self->{tables}{$self->tablename("head")} )
3fda8c4c 3734 {
6aeeffd1
JE
3735 my $tablename = $self->tablename("head");
3736 my $ix1name = $self->tablename("head_ix1");
3fda8c4c 3737 $self->{dbh}->do("
6aeeffd1 3738 CREATE TABLE $tablename (
3fda8c4c
ML
3739 name TEXT NOT NULL,
3740 revision INTEGER NOT NULL,
3741 filehash TEXT NOT NULL,
3742 commithash TEXT NOT NULL,
3743 author TEXT NOT NULL,
3744 modified TEXT NOT NULL,
3745 mode TEXT NOT NULL
3746 )
3747 ");
178e015c 3748 $self->{dbh}->do("
6aeeffd1
JE
3749 CREATE INDEX $ix1name
3750 ON $tablename (name)
178e015c 3751 ");
3fda8c4c
ML
3752 }
3753
3754 # Construct the properties table if required
196e48f4 3755 # - "last_commit" - Used by "sub update".
6aeeffd1 3756 unless ( $self->{tables}{$self->tablename("properties")} )
3fda8c4c 3757 {
6aeeffd1 3758 my $tablename = $self->tablename("properties");
3fda8c4c 3759 $self->{dbh}->do("
6aeeffd1 3760 CREATE TABLE $tablename (
3fda8c4c
ML
3761 key TEXT NOT NULL PRIMARY KEY,
3762 value TEXT
3763 )
3764 ");
3765 }
3766
3767 # Construct the commitmsgs table if required
196e48f4
MO
3768 # The commitmsgs table is only used for merge commits, since
3769 # "sub update" will only keep one branch of parents. Shortlogs
3770 # for ignored commits (i.e. not on the chosen branch) will be used
3771 # to construct a replacement "collapsed" merge commit message,
3772 # which will be stored in this table. See also "sub commitmessage".
6aeeffd1 3773 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3fda8c4c 3774 {
6aeeffd1 3775 my $tablename = $self->tablename("commitmsgs");
3fda8c4c 3776 $self->{dbh}->do("
6aeeffd1 3777 CREATE TABLE $tablename (
3fda8c4c
ML
3778 key TEXT NOT NULL PRIMARY KEY,
3779 value TEXT
3780 )
3781 ");
3782 }
3783
3784 return $self;
3785}
3786
6aeeffd1
JE
3787=head2 tablename
3788
3789=cut
3790sub tablename
3791{
3792 my $self = shift;
3793 my $name = shift;
3794
3795 if (exists $self->{valid_tables}{$name}) {
3796 return $self->{dbtablenameprefix} . $name;
3797 } else {
3798 return undef;
3799 }
3800}
3801
3fda8c4c
ML
3802=head2 update
3803
196e48f4
MO
3804Bring the database up to date with the latest changes from
3805the git repository.
3806
3807Internal working state is read out of the "head" table and the
3808"last_commit" property, then it updates "revisions" based on that, and
3809finally it writes the new internal state back to the "head" table
3810so it can be used as a starting point the next time update is called.
3811
3fda8c4c
ML
3812=cut
3813sub update
3814{
3815 my $self = shift;
3816
3817 # first lets get the commit list
3818 $ENV{GIT_DIR} = $self->{git_path};
3819
27dd7387 3820 my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
49fb940e
ML
3821 chomp $commitsha1;
3822
27dd7387 3823 my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
05ea93d6 3824 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ )
3fda8c4c
ML
3825 {
3826 die("Invalid module '$self->{module}'");
3827 }
3828
3829
3830 my $git_log;
3831 my $lastcommit = $self->_get_prop("last_commit");
3832
49fb940e 3833 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
61717661
MO
3834 # invalidate the gethead cache
3835 $self->clearCommitRefCaches();
49fb940e
ML
3836 return 1;
3837 }
3838
3fda8c4c
ML
3839 # Start exclusive lock here...
3840 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3841
3842 # TODO: log processing is memory bound
3843 # if we can parse into a 2nd file that is in reverse order
3844 # we can probably do something really efficient
a248c961 3845 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3fda8c4c
ML
3846
3847 if (defined $lastcommit) {
3848 push @git_log_params, "$lastcommit..$self->{module}";
3849 } else {
3850 push @git_log_params, $self->{module};
3851 }
a248c961 3852 # git-rev-list is the backend / plumbing version of git-log
2c3af7e7
MO
3853 open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
3854 or die "Cannot call git-rev-list: $!";
3855 my @commits=readCommits($gitLogPipe);
3856 close $gitLogPipe;
3fda8c4c
ML
3857
3858 # Now all the commits are in the @commits bucket
3859 # ordered by time DESC. for each commit that needs processing,
3860 # determine whether it's following the last head we've seen or if
3861 # it's on its own branch, grab a file list, and add whatever's changed
3862 # NOTE: $lastcommit refers to the last commit from previous run
3863 # $lastpicked is the last commit we picked in this run
3864 my $lastpicked;
3865 my $head = {};
3866 if (defined $lastcommit) {
3867 $lastpicked = $lastcommit;
3868 }
3869
3870 my $committotal = scalar(@commits);
3871 my $commitcount = 0;
3872
3873 # Load the head table into $head (for cached lookups during the update process)
ab07681f 3874 foreach my $file ( @{$self->gethead(1)} )
3fda8c4c
ML
3875 {
3876 $head->{$file->{name}} = $file;
3877 }
3878
3879 foreach my $commit ( @commits )
3880 {
3881 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3882 if (defined $lastpicked)
3883 {
3884 if (!in_array($lastpicked, @{$commit->{parents}}))
3885 {
3886 # skip, we'll see this delta
3887 # as part of a merge later
3888 # warn "skipping off-track $commit->{hash}\n";
3889 next;
3890 } elsif (@{$commit->{parents}} > 1) {
3891 # it is a merge commit, for each parent that is
196e48f4
MO
3892 # not $lastpicked (not given a CVS revision number),
3893 # see if we can get a log
3fda8c4c
ML
3894 # from the merge-base to that parent to put it
3895 # in the message as a merge summary.
3896 my @parents = @{$commit->{parents}};
3897 foreach my $parent (@parents) {
3fda8c4c
ML
3898 if ($parent eq $lastpicked) {
3899 next;
3900 }
196e48f4
MO
3901 # git-merge-base can potentially (but rarely) throw
3902 # several candidate merge bases. let's assume
3903 # that the first one is the best one.
e509db99 3904 my $base = eval {
fce13af5 3905 ::safe_pipe_capture('git', 'merge-base',
a5e40798 3906 $lastpicked, $parent);
e509db99
SP
3907 };
3908 # The two branches may not be related at all,
3909 # in which case merge base simply fails to find
3910 # any, but that's Ok.
3911 next if ($@);
3912
3fda8c4c
ML
3913 chomp $base;
3914 if ($base) {
3915 my @merged;
3916 # print "want to log between $base $parent \n";
d2feb01a 3917 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
a5e40798 3918 or die "Cannot call git-log: $!";
3fda8c4c
ML
3919 my $mergedhash;
3920 while (<GITLOG>) {
3921 chomp;
3922 if (!defined $mergedhash) {
3923 if (m/^commit\s+(.+)$/) {
3924 $mergedhash = $1;
3925 } else {
3926 next;
3927 }
3928 } else {
3929 # grab the first line that looks non-rfc822
3930 # aka has content after leading space
3931 if (m/^\s+(\S.*)$/) {
3932 my $title = $1;
3933 $title = substr($title,0,100); # truncate
3934 unshift @merged, "$mergedhash $title";
3935 undef $mergedhash;
3936 }
3937 }
3938 }
3939 close GITLOG;
3940 if (@merged) {
3941 $commit->{mergemsg} = $commit->{message};
3942 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3943 foreach my $summary (@merged) {
3944 $commit->{mergemsg} .= "\t$summary\n";
3945 }
3946 $commit->{mergemsg} .= "\n\n";
3947 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3948 }
3949 }
3950 }
3951 }
3952 }
3953
3954 # convert the date to CVS-happy format
2c3af7e7 3955 my $cvsDate = convertToCvsDate($commit->{date});
3fda8c4c
ML
3956
3957 if ( defined ( $lastpicked ) )
3958 {
d2feb01a 3959 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
e02cd638 3960 local ($/) = "\0";
3fda8c4c
ML
3961 while ( <FILELIST> )
3962 {
e02cd638 3963 chomp;
05ea93d6 3964 unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o )
3fda8c4c
ML
3965 {
3966 die("Couldn't process git-diff-tree line : $_");
3967 }
e02cd638
JH
3968 my ($mode, $hash, $change) = ($1, $2, $3);
3969 my $name = <FILELIST>;
3970 chomp($name);
3fda8c4c 3971
e02cd638 3972 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3fda8c4c 3973
2c3af7e7 3974 my $dbMode = convertToDbMode($mode);
3fda8c4c 3975
e02cd638 3976 if ( $change eq "D" )
3fda8c4c 3977 {
e02cd638
JH
3978 #$log->debug("DELETE $name");
3979 $head->{$name} = {
3980 name => $name,
3981 revision => $head->{$name}{revision} + 1,
3fda8c4c
ML
3982 filehash => "deleted",
3983 commithash => $commit->{hash},
2c3af7e7 3984 modified => $cvsDate,
3fda8c4c 3985 author => $commit->{author},
2c3af7e7 3986 mode => $dbMode,
3fda8c4c 3987 };
2c3af7e7 3988 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c 3989 }
9027efed 3990 elsif ( $change eq "M" || $change eq "T" )
3fda8c4c 3991 {
e02cd638
JH
3992 #$log->debug("MODIFIED $name");
3993 $head->{$name} = {
3994 name => $name,
3995 revision => $head->{$name}{revision} + 1,
3996 filehash => $hash,
3fda8c4c 3997 commithash => $commit->{hash},
2c3af7e7 3998 modified => $cvsDate,
3fda8c4c 3999 author => $commit->{author},
2c3af7e7 4000 mode => $dbMode,
3fda8c4c 4001 };
2c3af7e7 4002 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c 4003 }
e02cd638 4004 elsif ( $change eq "A" )
3fda8c4c 4005 {
e02cd638
JH
4006 #$log->debug("ADDED $name");
4007 $head->{$name} = {
4008 name => $name,
a7da9adb 4009 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
e02cd638 4010 filehash => $hash,
3fda8c4c 4011 commithash => $commit->{hash},
2c3af7e7 4012 modified => $cvsDate,
3fda8c4c 4013 author => $commit->{author},
2c3af7e7 4014 mode => $dbMode,
3fda8c4c 4015 };
2c3af7e7 4016 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c
ML
4017 }
4018 else
4019 {
e02cd638 4020 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3fda8c4c
ML
4021 die;
4022 }
4023 }
4024 close FILELIST;
4025 } else {
4026 # this is used to detect files removed from the repo
4027 my $seen_files = {};
4028
d2feb01a 4029 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
e02cd638 4030 local $/ = "\0";
3fda8c4c
ML
4031 while ( <FILELIST> )
4032 {
e02cd638
JH
4033 chomp;
4034 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3fda8c4c
ML
4035 {
4036 die("Couldn't process git-ls-tree line : $_");
4037 }
4038
2c3af7e7 4039 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3fda8c4c
ML
4040
4041 $seen_files->{$git_filename} = 1;
4042
4043 my ( $oldhash, $oldrevision, $oldmode ) = (
4044 $head->{$git_filename}{filehash},
4045 $head->{$git_filename}{revision},
4046 $head->{$git_filename}{mode}
4047 );
4048
2c3af7e7 4049 my $dbMode = convertToDbMode($mode);
3fda8c4c
ML
4050
4051 # unless the file exists with the same hash, we need to update it ...
2c3af7e7 4052 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
3fda8c4c
ML
4053 {
4054 my $newrevision = ( $oldrevision or 0 ) + 1;
4055
4056 $head->{$git_filename} = {
4057 name => $git_filename,
4058 revision => $newrevision,
4059 filehash => $git_hash,
4060 commithash => $commit->{hash},
2c3af7e7 4061 modified => $cvsDate,
3fda8c4c 4062 author => $commit->{author},
2c3af7e7 4063 mode => $dbMode,
3fda8c4c
ML
4064 };
4065
4066
2c3af7e7 4067 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c
ML
4068 }
4069 }
4070 close FILELIST;
4071
4072 # Detect deleted files
9462953a 4073 foreach my $file ( sort keys %$head )
3fda8c4c
ML
4074 {
4075 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
4076 {
4077 $head->{$file}{revision}++;
4078 $head->{$file}{filehash} = "deleted";
4079 $head->{$file}{commithash} = $commit->{hash};
2c3af7e7 4080 $head->{$file}{modified} = $cvsDate;
3fda8c4c
ML
4081 $head->{$file}{author} = $commit->{author};
4082
2c3af7e7 4083 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
3fda8c4c
ML
4084 }
4085 }
4086 # END : "Detect deleted files"
4087 }
4088
4089
4090 if (exists $commit->{mergemsg})
4091 {
96256bba 4092 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3fda8c4c
ML
4093 }
4094
4095 $lastpicked = $commit->{hash};
4096
4097 $self->_set_prop("last_commit", $commit->{hash});
4098 }
4099
96256bba 4100 $self->delete_head();
9462953a 4101 foreach my $file ( sort keys %$head )
3fda8c4c 4102 {
96256bba 4103 $self->insert_head(
3fda8c4c
ML
4104 $file,
4105 $head->{$file}{revision},
4106 $head->{$file}{filehash},
4107 $head->{$file}{commithash},
4108 $head->{$file}{modified},
4109 $head->{$file}{author},
4110 $head->{$file}{mode},
4111 );
4112 }
4113 # invalidate the gethead cache
658b57ad 4114 $self->clearCommitRefCaches();
3fda8c4c
ML
4115
4116
4117 # Ending exclusive lock here
4118 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
4119}
4120
2c3af7e7
MO
4121sub readCommits
4122{
4123 my $pipeHandle = shift;
4124 my @commits;
4125
4126 my %commit = ();
4127
4128 while ( <$pipeHandle> )
4129 {
4130 chomp;
4131 if (m/^commit\s+(.*)$/) {
4132 # on ^commit lines put the just seen commit in the stack
4133 # and prime things for the next one
4134 if (keys %commit) {
4135 my %copy = %commit;
4136 unshift @commits, \%copy;
4137 %commit = ();
4138 }
4139 my @parents = split(m/\s+/, $1);
4140 $commit{hash} = shift @parents;
4141 $commit{parents} = \@parents;
4142 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
4143 # on rfc822-like lines seen before we see any message,
4144 # lowercase the entry and put it in the hash as key-value
4145 $commit{lc($1)} = $2;
4146 } else {
4147 # message lines - skip initial empty line
4148 # and trim whitespace
4149 if (!exists($commit{message}) && m/^\s*$/) {
4150 # define it to mark the end of headers
4151 $commit{message} = '';
4152 next;
4153 }
4154 s/^\s+//; s/\s+$//; # trim ws
4155 $commit{message} .= $_ . "\n";
4156 }
4157 }
4158
4159 unshift @commits, \%commit if ( keys %commit );
4160
4161 return @commits;
4162}
4163
4164sub convertToCvsDate
4165{
4166 my $date = shift;
4167 # Convert from: "git rev-list --pretty" formatted date
4168 # Convert to: "the format specified by RFC822 as modified by RFC1123."
4169 # Example: 26 May 1997 13:01:40 -0400
4170 if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
4171 {
4172 $date = "$2 $1 $4 $3 $5";
4173 }
4174
4175 return $date;
4176}
4177
4178sub convertToDbMode
4179{
4180 my $mode = shift;
4181
4182 # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
4183 # but the database "mode" column historically (and currently)
4184 # only stores the "rw" (for user) part of the string.
4185 # FUTURE: It might make more sense to persist the raw
4186 # octal mode (or perhaps the final full CVS form) instead of
4187 # this half-converted form, but it isn't currently worth the
4188 # backwards compatibility headaches.
4189
1b48d56c 4190 $mode=~/^\d{3}(\d)\d\d$/;
2c3af7e7
MO
4191 my $userBits=$1;
4192
4193 my $dbMode = "";
4194 $dbMode .= "r" if ( $userBits & 4 );
4195 $dbMode .= "w" if ( $userBits & 2 );
4196 $dbMode .= "x" if ( $userBits & 1 );
4197 $dbMode = "rw" if ( $dbMode eq "" );
4198
4199 return $dbMode;
4200}
4201
96256bba
JS
4202sub insert_rev
4203{
4204 my $self = shift;
4205 my $name = shift;
4206 my $revision = shift;
4207 my $filehash = shift;
4208 my $commithash = shift;
4209 my $modified = shift;
4210 my $author = shift;
4211 my $mode = shift;
6aeeffd1 4212 my $tablename = $self->tablename("revision");
96256bba 4213
6aeeffd1 4214 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
96256bba
JS
4215 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4216}
4217
4218sub insert_mergelog
4219{
4220 my $self = shift;
4221 my $key = shift;
4222 my $value = shift;
6aeeffd1 4223 my $tablename = $self->tablename("commitmsgs");
96256bba 4224
6aeeffd1 4225 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
96256bba
JS
4226 $insert_mergelog->execute($key, $value);
4227}
4228
4229sub delete_head
4230{
4231 my $self = shift;
6aeeffd1 4232 my $tablename = $self->tablename("head");
96256bba 4233
6aeeffd1 4234 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
96256bba
JS
4235 $delete_head->execute();
4236}
4237
4238sub insert_head
4239{
4240 my $self = shift;
4241 my $name = shift;
4242 my $revision = shift;
4243 my $filehash = shift;
4244 my $commithash = shift;
4245 my $modified = shift;
4246 my $author = shift;
4247 my $mode = shift;
6aeeffd1 4248 my $tablename = $self->tablename("head");
96256bba 4249
6aeeffd1 4250 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
96256bba
JS
4251 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4252}
4253
3fda8c4c
ML
4254sub _get_prop
4255{
4256 my $self = shift;
4257 my $key = shift;
6aeeffd1 4258 my $tablename = $self->tablename("properties");
3fda8c4c 4259
6aeeffd1 4260 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3fda8c4c
ML
4261 $db_query->execute($key);
4262 my ( $value ) = $db_query->fetchrow_array;
4263
4264 return $value;
4265}
4266
4267sub _set_prop
4268{
4269 my $self = shift;
4270 my $key = shift;
4271 my $value = shift;
6aeeffd1 4272 my $tablename = $self->tablename("properties");
3fda8c4c 4273
6aeeffd1 4274 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3fda8c4c
ML
4275 $db_query->execute($value, $key);
4276
4277 unless ( $db_query->rows )
4278 {
6aeeffd1 4279 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3fda8c4c
ML
4280 $db_query->execute($key, $value);
4281 }
4282
4283 return $value;
4284}
4285
4286=head2 gethead
4287
4288=cut
4289
4290sub gethead
4291{
4292 my $self = shift;
ab07681f 4293 my $intRev = shift;
6aeeffd1 4294 my $tablename = $self->tablename("head");
3fda8c4c
ML
4295
4296 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
4297
6aeeffd1 4298 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3fda8c4c
ML
4299 $db_query->execute();
4300
4301 my $tree = [];
4302 while ( my $file = $db_query->fetchrow_hashref )
4303 {
ab07681f
MO
4304 if(!$intRev)
4305 {
4306 $file->{revision} = "1.$file->{revision}"
4307 }
3fda8c4c
ML
4308 push @$tree, $file;
4309 }
4310
4311 $self->{gethead_cache} = $tree;
4312
4313 return $tree;
4314}
4315
658b57ad
MO
4316=head2 getAnyHead
4317
4318Returns a reference to an array of getmeta structures, one
4319per file in the specified tree hash.
4320
4321=cut
4322
4323sub getAnyHead
4324{
4325 my ($self,$hash) = @_;
4326
4327 if(!defined($hash))
4328 {
4329 return $self->gethead();
4330 }
4331
4332 my @files;
4333 {
4334 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4335 or die("Cannot call git-ls-tree : $!");
4336 local $/ = "\0";
4337 @files=<$filePipe>;
4338 close $filePipe;
4339 }
4340
4341 my $tree=[];
4342 my($line);
4343 foreach $line (@files)
4344 {
4345 $line=~s/\0$//;
4346 unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4347 {
4348 die("Couldn't process git-ls-tree line : $_");
4349 }
4350
4351 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4352 push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
4353 }
4354
4355 return $tree;
4356}
4357
4358=head2 getRevisionDirMap
4359
4360A "revision dir map" contains all the plain-file filenames associated
bb8040f9 4361with a particular revision (tree-ish), organized by directory:
658b57ad
MO
4362
4363 $type = $out->{$dir}{$fullName}
4364
4365The type of each is "F" (for ordinary file) or "D" (for directory,
4366for which the map $out->{$fullName} will also exist).
4367
4368=cut
4369
4370sub getRevisionDirMap
4371{
4372 my ($self,$ver)=@_;
4373
4374 if(!defined($self->{revisionDirMapCache}))
4375 {
4376 $self->{revisionDirMapCache}={};
4377 }
4378
4379 # Get file list (previously cached results are dependent on HEAD,
4380 # but are early in each case):
4381 my $cacheKey;
4382 my (@fileList);
4383 if( !defined($ver) || $ver eq "" )
4384 {
4385 $cacheKey="";
4386 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4387 {
4388 return $self->{revisionDirMapCache}{$cacheKey};
4389 }
4390
4391 my @head = @{$self->gethead()};
4392 foreach my $file ( @head )
4393 {
4394 next if ( $file->{filehash} eq "deleted" );
4395
4396 push @fileList,$file->{name};
4397 }
4398 }
4399 else
4400 {
4401 my ($hash)=$self->lookupCommitRef($ver);
4402 if( !defined($hash) )
4403 {
4404 return undef;
4405 }
4406
4407 $cacheKey=$hash;
4408 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4409 {
4410 return $self->{revisionDirMapCache}{$cacheKey};
4411 }
4412
4413 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4414 or die("Cannot call git-ls-tree : $!");
4415 local $/ = "\0";
4416 while ( <$filePipe> )
4417 {
4418 chomp;
4419 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4420 {
4421 die("Couldn't process git-ls-tree line : $_");
4422 }
4423
4424 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4425
4426 push @fileList, $git_filename;
4427 }
4428 close $filePipe;
4429 }
4430
4431 # Convert to normalized form:
4432 my %revMap;
4433 my $file;
4434 foreach $file (@fileList)
4435 {
4436 my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
4437 $dir='' if(!defined($dir));
4438
4439 # parent directories:
4440 # ... create empty dir maps for parent dirs:
4441 my($td)=$dir;
4442 while(!defined($revMap{$td}))
4443 {
4444 $revMap{$td}={};
4445
4446 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4447 $tp='' if(!defined($tp));
4448 $td=$tp;
4449 }
4450 # ... add children to parent maps (now that they exist):
4451 $td=$dir;
4452 while($td ne "")
4453 {
4454 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4455 $tp='' if(!defined($tp));
4456
4457 if(defined($revMap{$tp}{$td}))
4458 {
4459 if($revMap{$tp}{$td} ne 'D')
4460 {
4461 die "Weird file/directory inconsistency in $cacheKey";
4462 }
4463 last; # loop exit
4464 }
4465 $revMap{$tp}{$td}='D';
4466
4467 $td=$tp;
4468 }
4469
4470 # file
4471 $revMap{$dir}{$file}='F';
4472 }
4473
4474 # Save in cache:
4475 $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
4476 return $self->{revisionDirMapCache}{$cacheKey};
4477}
4478
3fda8c4c
ML
4479=head2 getlog
4480
a86c0983
MO
4481See also gethistorydense().
4482
3fda8c4c
ML
4483=cut
4484
4485sub getlog
4486{
4487 my $self = shift;
4488 my $filename = shift;
ab07681f
MO
4489 my $revFilter = shift;
4490
6aeeffd1 4491 my $tablename = $self->tablename("revision");
3fda8c4c 4492
ab07681f
MO
4493 # Filters:
4494 # TODO: date, state, or by specific logins filters?
4495 # TODO: Handle comma-separated list of revFilter items, each item
4496 # can be a range [only case currently handled] or individual
4497 # rev or branch or "branch.".
4498 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
4499 # manually filtering the results of the query?
4500 my ( $minrev, $maxrev );
4501 if( defined($revFilter) and
4502 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
4503 {
4504 my $control = $3;
4505 $minrev = $2;
4506 $maxrev = $5;
4507 $minrev++ if ( defined($minrev) and $control eq "::" );
4508 }
4509
6aeeffd1 4510 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
4511 $db_query->execute($filename);
4512
ab07681f 4513 my $totalRevs=0;
3fda8c4c
ML
4514 my $tree = [];
4515 while ( my $file = $db_query->fetchrow_hashref )
4516 {
ab07681f
MO
4517 $totalRevs++;
4518 if( defined($minrev) and $file->{revision} < $minrev )
4519 {
4520 next;
4521 }
4522 if( defined($maxrev) and $file->{revision} > $maxrev )
4523 {
4524 next;
4525 }
4526
4527 $file->{revision} = "1." . $file->{revision};
3fda8c4c
ML
4528 push @$tree, $file;
4529 }
4530
ab07681f 4531 return ($tree,$totalRevs);
3fda8c4c
ML
4532}
4533
4534=head2 getmeta
4535
4536This function takes a filename (with path) argument and returns a hashref of
4537metadata for that file.
4538
bfdafa09
MO
4539There are several ways $revision can be specified:
4540
4541 - A reference to hash that contains a "tag" that is the
4542 actual revision (one of the below). TODO: Also allow it to
4543 specify a "date" in the hash.
4544 - undef, to refer to the latest version on the main branch.
4545 - Full CVS client revision number (mapped to integer in DB, without the
4546 "1." prefix),
4547 - Complex CVS-compatible "special" revision number for
4548 non-linear history (see comment below)
4549 - git commit sha1 hash
4550 - branch or tag name
4551
3fda8c4c
ML
4552=cut
4553
4554sub getmeta
4555{
4556 my $self = shift;
4557 my $filename = shift;
4558 my $revision = shift;
6aeeffd1
JE
4559 my $tablename_rev = $self->tablename("revision");
4560 my $tablename_head = $self->tablename("head");
3fda8c4c 4561
bfdafa09 4562 if ( ref($revision) eq "HASH" )
3fda8c4c 4563 {
bfdafa09 4564 $revision = $revision->{tag};
3fda8c4c 4565 }
bfdafa09
MO
4566
4567 # Overview of CVS revision numbers:
4568 #
4569 # General CVS numbering scheme:
4570 # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
4571 # - Result of "cvs checkin -r" (possible, but not really
4572 # recommended): "2.1", "2.2", etc
4573 # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
4574 # from, "0" is a magic placeholder that identifies it as a
4575 # branch tag instead of a version tag, and n is 2 times the
4576 # branch number off of "1.2", starting with "2".
4577 # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
4578 # is branch number off of "1.2" (like n above), and "x" is
4579 # the version number on the branch.
4580 # - Branches can branch off of branches: "1.3.2.7.4.1" (even number
4581 # of components).
4582 # - Odd "n"s are used by "vendor branches" that result
4583 # from "cvs import". Vendor branches have additional
4584 # strangeness in the sense that the main rcs "head" of the main
4585 # branch will (temporarily until first normal commit) point
4586 # to the version on the vendor branch, rather than the actual
4587 # main branch. (FUTURE: This may provide an opportunity
4588 # to use "strange" revision numbers for fast-forward-merged
4589 # branch tip when CVS client is asking for the main branch.)
4590 #
4591 # git-cvsserver CVS-compatible special numbering schemes:
4592 # - Currently git-cvsserver only tries to be identical to CVS for
4593 # simple "1.x" numbers on the "main" branch (as identified
4594 # by the module name that was originally cvs checkout'ed).
4595 # - The database only stores the "x" part, for historical reasons.
4596 # But most of the rest of the cvsserver preserves
4597 # and thinks using the full revision number.
4598 # - To handle non-linear history, it uses a version of the form
4599 # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
4600 # identify this as a special revision number, and there are
4601 # 20 b's that together encode the sha1 git commit from which
4602 # this version of this file originated. Each b is
4603 # the numerical value of the corresponding byte plus
4604 # 100.
4605 # - "plus 100" avoids "0"s, and also reduces the
41ccfdd9 4606 # likelihood of a collision in the case that someone someday
bfdafa09
MO
4607 # writes an import tool that tries to preserve original
4608 # CVS revision numbers, and the original CVS data had done
4609 # lots of branches off of branches and other strangeness to
4610 # end up with a real version number that just happens to look
4611 # like this special revision number form. Also, if needed
4612 # there are several ways to extend/identify alternative encodings
4613 # within the "2.1.1.2000" part if necessary.
4614 # - Unlike real CVS revisions, you can't really reconstruct what
4615 # relation a revision of this form has to other revisions.
4616 # - FUTURE: TODO: Rework database somehow to make up and remember
4617 # fully-CVS-compatible branches and branch version numbers.
4618
4619 my $meta;
4620 if ( defined($revision) )
3fda8c4c 4621 {
bfdafa09
MO
4622 if ( $revision =~ /^1\.(\d+)$/ )
4623 {
4624 my ($intRev) = $1;
4625 my $db_query;
4626 $db_query = $self->{dbh}->prepare_cached(
4627 "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
4628 {},1);
4629 $db_query->execute($filename, $intRev);
4630 $meta = $db_query->fetchrow_hashref;
4631 }
05ea93d6 4632 elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ )
bfdafa09
MO
4633 {
4634 my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
4635 $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
05ea93d6 4636 if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)
bfdafa09
MO
4637 {
4638 return $self->getMetaFromCommithash($filename,$commitHash);
4639 }
4640
4641 # error recovery: fall back on head version below
4642 print "E Failed to find $filename version=$revision or commit=$commitHash\n";
4643 $log->warning("failed get $revision with commithash=$commitHash");
4644 undef $revision;
4645 }
05ea93d6 4646 elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ )
bfdafa09
MO
4647 {
4648 # Try DB first. This is mostly only useful for req_annotate(),
4649 # which only calls this for stuff that should already be in
4650 # the DB. It is fairly likely to be a waste of time
4651 # in most other cases [unless the file happened to be
4652 # modified in $revision specifically], but
4653 # it is probably in the noise compared to how long
4654 # getMetaFromCommithash() will take.
4655 my $db_query;
4656 $db_query = $self->{dbh}->prepare_cached(
4657 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4658 {},1);
4659 $db_query->execute($filename, $revision);
4660 $meta = $db_query->fetchrow_hashref;
4661
4662 if(! $meta)
4663 {
4664 my($revCommit)=$self->lookupCommitRef($revision);
05ea93d6 4665 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
bfdafa09
MO
4666 {
4667 return $self->getMetaFromCommithash($filename,$revCommit);
4668 }
4669
4670 # error recovery: nothing found:
4671 print "E Failed to find $filename version=$revision\n";
4672 $log->warning("failed get $revision");
4673 return $meta;
4674 }
4675 }
4676 else
4677 {
4678 my($revCommit)=$self->lookupCommitRef($revision);
05ea93d6 4679 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
bfdafa09
MO
4680 {
4681 return $self->getMetaFromCommithash($filename,$revCommit);
4682 }
4683
4684 # error recovery: fall back on head version below
4685 print "E Failed to find $filename version=$revision\n";
4686 $log->warning("failed get $revision");
4687 undef $revision; # Allow fallback
4688 }
4689 }
4690
4691 if(!defined($revision))
4692 {
4693 my $db_query;
4694 $db_query = $self->{dbh}->prepare_cached(
4695 "SELECT * FROM $tablename_head WHERE name=?",{},1);
3fda8c4c 4696 $db_query->execute($filename);
bfdafa09 4697 $meta = $db_query->fetchrow_hashref;
3fda8c4c
ML
4698 }
4699
ab07681f
MO
4700 if($meta)
4701 {
4702 $meta->{revision} = "1.$meta->{revision}";
4703 }
4704 return $meta;
3fda8c4c
ML
4705}
4706
658b57ad
MO
4707sub getMetaFromCommithash
4708{
4709 my $self = shift;
4710 my $filename = shift;
4711 my $revCommit = shift;
4712
4713 # NOTE: This function doesn't scale well (lots of forks), especially
4714 # if you have many files that have not been modified for many commits
4715 # (each git-rev-parse redoes a lot of work for each file
4716 # that theoretically could be done in parallel by smarter
4717 # graph traversal).
4718 #
4719 # TODO: Possible optimization strategies:
4720 # - Solve the issue of assigning and remembering "real" CVS
4721 # revision numbers for branches, and ensure the
4722 # data structure can do this efficiently. Perhaps something
4723 # similar to "git notes", and carefully structured to take
4724 # advantage same-sha1-is-same-contents, to roll the same
4725 # unmodified subdirectory data onto multiple commits?
4726 # - Write and use a C tool that is like git-blame, but
4727 # operates on multiple files with file granularity, instead
4728 # of one file with line granularity. Cache
4729 # most-recently-modified in $self->{commitRefCache}{$revCommit}.
4730 # Try to be intelligent about how many files we do with
4731 # one fork (perhaps one directory at a time, without recursion,
4732 # and/or include directory as one line item, recurse from here
4733 # instead of in C tool?).
4734 # - Perhaps we could ask the DB for (filename,fileHash),
4735 # and just guess that it is correct (that the file hadn't
4736 # changed between $revCommit and the found commit, then
4737 # changed back, confusing anything trying to interpret
4738 # history). Probably need to add another index to revisions
4739 # DB table for this.
4740 # - NOTE: Trying to store all (commit,file) keys in DB [to
4741 # find "lastModfiedCommit] (instead of
4742 # just files that changed in each commit as we do now) is
4743 # probably not practical from a disk space perspective.
4744
4745 # Does the file exist in $revCommit?
4746 # TODO: Include file hash in dirmap cache.
4747 my($dirMap)=$self->getRevisionDirMap($revCommit);
4748 my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
4749 if(!defined($dir))
4750 {
4751 $dir="";
4752 }
4753 if( !defined($dirMap->{$dir}) ||
4754 !defined($dirMap->{$dir}{$filename}) )
4755 {
4756 my($fileHash)="deleted";
4757
4758 my($retVal)={};
4759 $retVal->{name}=$filename;
4760 $retVal->{filehash}=$fileHash;
4761
4762 # not needed and difficult to compute:
4763 $retVal->{revision}="0"; # $revision;
4764 $retVal->{commithash}=$revCommit;
4765 #$retVal->{author}=$commit->{author};
4766 #$retVal->{modified}=convertToCvsDate($commit->{date});
4767 #$retVal->{mode}=convertToDbMode($mode);
4768
4769 return $retVal;
4770 }
4771
fce13af5 4772 my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
658b57ad 4773 chomp $fileHash;
05ea93d6 4774 if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/))
658b57ad
MO
4775 {
4776 die "Invalid fileHash '$fileHash' looking up"
4777 ." '$revCommit:$filename'\n";
4778 }
4779
4780 # information about most recent commit to modify $filename:
4781 open(my $gitLogPipe, '-|', 'git', 'rev-list',
4782 '--max-count=1', '--pretty', '--parents',
4783 $revCommit, '--', $filename)
4784 or die "Cannot call git-rev-list: $!";
4785 my @commits=readCommits($gitLogPipe);
4786 close $gitLogPipe;
4787 if(scalar(@commits)!=1)
4788 {
4789 die "Can't find most recent commit changing $filename\n";
4790 }
4791 my($commit)=$commits[0];
4792 if( !defined($commit) || !defined($commit->{hash}) )
4793 {
4794 return undef;
4795 }
4796
4797 # does this (commit,file) have a real assigned CVS revision number?
4798 my $tablename_rev = $self->tablename("revision");
4799 my $db_query;
4800 $db_query = $self->{dbh}->prepare_cached(
4801 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4802 {},1);
4803 $db_query->execute($filename, $commit->{hash});
4804 my($meta)=$db_query->fetchrow_hashref;
4805 if($meta)
4806 {
4807 $meta->{revision} = "1.$meta->{revision}";
4808 return $meta;
4809 }
4810
4811 # fall back on special revision number
4812 my($revision)=$commit->{hash};
4813 $revision=~s/(..)/'.' . (hex($1)+100)/eg;
4814 $revision="2.1.1.2000$revision";
4815
4816 # meta data about $filename:
4817 open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
4818 $commit->{hash}, '--', $filename)
4819 or die("Cannot call git-ls-tree : $!");
4820 local $/ = "\0";
4821 my $line;
4822 $line=<$filePipe>;
4823 if(defined(<$filePipe>))
4824 {
4825 die "Expected only a single file for git-ls-tree $filename\n";
4826 }
4827 close $filePipe;
4828
4829 chomp $line;
4830 unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4831 {
4832 die("Couldn't process git-ls-tree line : $line\n");
4833 }
4834 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4835
4836 # save result:
4837 my($retVal)={};
4838 $retVal->{name}=$filename;
4839 $retVal->{revision}=$revision;
4840 $retVal->{filehash}=$fileHash;
4841 $retVal->{commithash}=$revCommit;
4842 $retVal->{author}=$commit->{author};
4843 $retVal->{modified}=convertToCvsDate($commit->{date});
4844 $retVal->{mode}=convertToDbMode($mode);
4845
4846 return $retVal;
4847}
4848
4849=head2 lookupCommitRef
4850
4851Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches
4852the result so looking it up again is fast.
4853
4854=cut
4855
4856sub lookupCommitRef
4857{
4858 my $self = shift;
4859 my $ref = shift;
4860
4861 my $commitHash = $self->{commitRefCache}{$ref};
4862 if(defined($commitHash))
4863 {
4864 return $commitHash;
4865 }
4866
fce13af5
JH
4867 $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
4868 $self->unescapeRefName($ref));
658b57ad 4869 $commitHash=~s/\s*$//;
05ea93d6 4870 if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/))
658b57ad
MO
4871 {
4872 $commitHash=undef;
4873 }
4874
4875 if( defined($commitHash) )
4876 {
fce13af5 4877 my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
658b57ad
MO
4878 if( ! ($type=~/^commit\s*$/ ) )
4879 {
4880 $commitHash=undef;
4881 }
4882 }
4883 if(defined($commitHash))
4884 {
4885 $self->{commitRefCache}{$ref}=$commitHash;
4886 }
4887 return $commitHash;
4888}
4889
4890=head2 clearCommitRefCaches
4891
4892Clears cached commit cache (sha1's for various tags/abbeviations/etc),
4893and related caches.
4894
4895=cut
4896
4897sub clearCommitRefCaches
4898{
4899 my $self = shift;
4900 $self->{commitRefCache} = {};
4901 $self->{revisionDirMapCache} = undef;
4902 $self->{gethead_cache} = undef;
4903}
4904
3fda8c4c
ML
4905=head2 commitmessage
4906
4907this function takes a commithash and returns the commit message for that commit
4908
4909=cut
4910sub commitmessage
4911{
4912 my $self = shift;
4913 my $commithash = shift;
6aeeffd1 4914 my $tablename = $self->tablename("commitmsgs");
3fda8c4c 4915
05ea93d6 4916 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
3fda8c4c
ML
4917
4918 my $db_query;
6aeeffd1 4919 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3fda8c4c
ML
4920 $db_query->execute($commithash);
4921
4922 my ( $message ) = $db_query->fetchrow_array;
4923
4924 if ( defined ( $message ) )
4925 {
4926 $message .= " " if ( $message =~ /\n$/ );
4927 return $message;
4928 }
4929
fce13af5 4930 my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
3fda8c4c
ML
4931 shift @lines while ( $lines[0] =~ /\S/ );
4932 $message = join("",@lines);
4933 $message .= " " if ( $message =~ /\n$/ );
4934 return $message;
4935}
4936
3fda8c4c
ML
4937=head2 gethistorydense
4938
4939This function takes a filename (with path) argument and returns an arrayofarrays
4940containing revision,filehash,commithash ordered by revision descending.
4941
4942This version of gethistory skips deleted entries -- so it is useful for annotate.
4943The 'dense' part is a reference to a '--dense' option available for git-rev-list
4944and other git tools that depend on it.
4945
a86c0983
MO
4946See also getlog().
4947
3fda8c4c
ML
4948=cut
4949sub gethistorydense
4950{
4951 my $self = shift;
4952 my $filename = shift;
6aeeffd1 4953 my $tablename = $self->tablename("revision");
3fda8c4c
ML
4954
4955 my $db_query;
6aeeffd1 4956 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3fda8c4c
ML
4957 $db_query->execute($filename);
4958
ab07681f
MO
4959 my $result = $db_query->fetchall_arrayref;
4960
4961 my $i;
4962 for($i=0 ; $i<scalar(@$result) ; $i++)
4963 {
4964 $result->[$i][0]="1." . $result->[$i][0];
4965 }
4966
4967 return $result;
3fda8c4c
ML
4968}
4969
51a7e6db
MO
4970=head2 escapeRefName
4971
4972Apply an escape mechanism to compensate for characters that
4973git ref names can have that CVS tags can not.
4974
4975=cut
4976sub escapeRefName
4977{
4978 my($self,$refName)=@_;
4979
4980 # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
4981 # many contexts it can also be a CVS revision number).
4982 #
4983 # Git tags commonly use '/' and '.' as well, but also handle
4984 # anything else just in case:
4985 #
4986 # = "_-s-" For '/'.
4987 # = "_-p-" For '.'.
4988 # = "_-u-" For underscore, in case someone wants a literal "_-" in
4989 # a tag name.
4990 # = "_-xx-" Where "xx" is the hexadecimal representation of the
4991 # desired ASCII character byte. (for anything else)
4992
4993 if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
4994 {
4995 $refName=~s/_-/_-u--/g;
4996 $refName=~s/\./_-p-/g;
4997 $refName=~s%/%_-s-%g;
4998 $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
4999 }
5000}
5001
5002=head2 unescapeRefName
5003
5004Undo an escape mechanism to compensate for characters that
5005git ref names can have that CVS tags can not.
5006
5007=cut
5008sub unescapeRefName
5009{
5010 my($self,$refName)=@_;
5011
5012 # see escapeRefName() for description of escape mechanism.
5013
5014 $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
5015
5016 # allowed tag names
5017 # TODO: Perhaps use git check-ref-format, with an in-process cache of
5018 # validated names?
5019 if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
5020 ( $refName=~m%[/.]$% ) ||
5021 ( $refName=~/\.lock$/ ) ||
5022 ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching }
5023 {
5024 # Error:
5025 $log->warn("illegal refName: $refName");
5026 $refName=undef;
5027 }
5028 return $refName;
5029}
5030
5031sub unescapeRefNameChar
5032{
5033 my($char)=@_;
5034
5035 if($char eq "s")
5036 {
5037 $char="/";
5038 }
5039 elsif($char eq "p")
5040 {
5041 $char=".";
5042 }
5043 elsif($char eq "u")
5044 {
5045 $char="_";
5046 }
5047 elsif($char=~/^[0-9a-f][0-9a-f]$/)
5048 {
5049 $char=chr(hex($char));
5050 }
5051 else
5052 {
5053 # Error case: Maybe it has come straight from user, and
5054 # wasn't supposed to be escaped? Restore it the way we got it:
5055 $char="_-$char-";
5056 }
5057
5058 return $char;
5059}
5060
3fda8c4c
ML
5061=head2 in_array()
5062
5063from Array::PAT - mimics the in_array() function
5064found in PHP. Yuck but works for small arrays.
5065
5066=cut
5067sub in_array
5068{
5069 my ($check, @array) = @_;
5070 my $retval = 0;
5071 foreach my $test (@array){
5072 if($check eq $test){
5073 $retval = 1;
5074 }
5075 }
5076 return $retval;
5077}
5078
eb1780d4
FL
5079=head2 mangle_dirname
5080
5081create a string from a directory name that is suitable to use as
5082part of a filename, mainly by converting all chars except \w.- to _
5083
5084=cut
5085sub mangle_dirname {
5086 my $dirname = shift;
5087 return unless defined $dirname;
5088
5089 $dirname =~ s/[^\w.-]/_/g;
5090
5091 return $dirname;
5092}
3fda8c4c 5093
6aeeffd1
JE
5094=head2 mangle_tablename
5095
5096create a string from a that is suitable to use as part of an SQL table
5097name, mainly by converting all chars except \w to _
5098
5099=cut
5100sub mangle_tablename {
5101 my $tablename = shift;
5102 return unless defined $tablename;
5103
5104 $tablename =~ s/[^\w_]/_/g;
5105
5106 return $tablename;
5107}
5108
3fda8c4c 51091;