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