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