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