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.
8 #### Copyright The Open University UK - 2006.
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@laptop.org>
14 #### Released under the GNU Public License, version 2.
24 use File
::Temp qw
/tempdir tempfile/;
25 use File
::Path qw
/rmtree/;
27 use Getopt
::Long
qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS
::log->new();
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
52 #### Definition and mappings of functions ####
54 # NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
55 # requests, this list is incomplete. It is missing many rarer/optional
56 # requests. Perhaps some clients require a claim of support for
57 # these specific requests for main functionality to work?
60 'Valid-responses' => \
&req_Validresponses
,
61 'valid-requests' => \
&req_validrequests
,
62 'Directory' => \
&req_Directory
,
63 'Entry' => \
&req_Entry
,
64 'Modified' => \
&req_Modified
,
65 'Unchanged' => \
&req_Unchanged
,
66 'Questionable' => \
&req_Questionable
,
67 'Argument' => \
&req_Argument
,
68 'Argumentx' => \
&req_Argument
,
69 'expand-modules' => \
&req_expandmodules
,
71 'remove' => \
&req_remove
,
73 'update' => \
&req_update
,
78 'tag' => \
&req_CATCHALL
,
79 'status' => \
&req_status
,
80 'admin' => \
&req_CATCHALL
,
81 'history' => \
&req_CATCHALL
,
82 'watchers' => \
&req_EMPTY
,
83 'editors' => \
&req_EMPTY
,
84 'noop' => \
&req_EMPTY
,
85 'annotate' => \
&req_annotate
,
86 'Global_option' => \
&req_Globaloption
,
89 ##############################################
92 # $state holds all the bits of information the clients sends us that could
93 # potentially be useful when it comes to actually _doing_ something.
94 my $state = { prependdir
=> '' };
96 # Work is for managing temporary working directory
99 state => undef, # undef, 1 (empty), 2 (with stuff)
106 $log->info("--------------- STARTING -----------------");
109 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
110 " --base-path <path> : Prepend to requested CVSROOT\n".
111 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
112 " --strict-paths : Don't allow recursing into subdirectories\n".
113 " --export-all : Don't check for gitcvs.enabled in config\n".
114 " --version, -V : Print version information and exit\n".
115 " -h, -H : Print usage information and exit\n".
117 "<directory> ... is a list of allowed directories. If no directories\n".
118 "are given, all are allowed. This is an additional restriction, gitcvs\n".
119 "access still needs to be enabled by the gitcvs.enabled config option.\n".
120 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
122 my @opts = ( 'h|H', 'version|V',
123 'base-path=s', 'strict-paths', 'export-all' );
124 GetOptions
( $state, @opts )
127 if ($state->{version
}) {
128 print "git-cvsserver version $VERSION\n";
131 if ($state->{help
}) {
136 my $TEMP_DIR = tempdir
( CLEANUP
=> 1 );
137 $log->debug("Temporary directory is '$TEMP_DIR'");
139 $state->{method
} = 'ext';
141 if ($ARGV[0] eq 'pserver') {
142 $state->{method
} = 'pserver';
144 } elsif ($ARGV[0] eq 'server') {
149 # everything else is a directory
150 $state->{allowed_roots
} = [ @ARGV ];
152 # don't export the whole system unless the users requests it
153 if ($state->{'export-all'} && !@
{$state->{allowed_roots
}}) {
154 die "--export-all can only be used together with an explicit whitelist\n";
157 # Environment handling for running under git-shell
158 if (exists $ENV{GIT_CVSSERVER_BASE_PATH
}) {
159 if ($state->{'base-path'}) {
160 die "Cannot specify base path both ways.\n";
162 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH
};
163 $state->{'base-path'} = $base_path;
164 $log->debug("Picked up base path '$base_path' from environment.\n");
166 if (exists $ENV{GIT_CVSSERVER_ROOT
}) {
167 if (@
{$state->{allowed_roots
}}) {
168 die "Cannot specify roots both ways: @ARGV\n";
170 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT
};
171 $state->{allowed_roots
} = [ $allowed_root ];
172 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
175 # if we are called with a pserver argument,
176 # deal with the authentication cat before entering the
178 if ($state->{method
} eq 'pserver') {
179 my $line = <STDIN
>; chomp $line;
180 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
181 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
184 $line = <STDIN
>; chomp $line;
185 unless (req_Root
('root', $line)) { # reuse Root
186 print "E Invalid root $line \n";
189 $line = <STDIN
>; chomp $line;
191 $line = <STDIN
>; chomp $line;
192 my $password = $line;
194 if ($user eq 'anonymous') {
195 # "A" will be 1 byte, use length instead in case the
196 # encryption method ever changes (yeah, right!)
197 if (length($password) > 1 ) {
198 print "E Don't supply a password for the `anonymous' user\n";
199 print "I HATE YOU\n";
203 # Fall through to LOVE
205 # Trying to authenticate a user
206 if (not exists $cfg->{gitcvs
}->{authdb
}) {
207 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
208 print "I HATE YOU\n";
212 my $authdb = $cfg->{gitcvs
}->{authdb
};
214 unless (-e
$authdb) {
215 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
216 print "I HATE YOU\n";
221 open my $passwd, "<", $authdb or die $!;
223 if (m{^\Q$user\E:(.*)}) {
224 if (crypt($user, descramble
($password)) eq $1) {
232 print "I HATE YOU\n";
236 # Fall through to LOVE
239 # For checking whether the user is anonymous on commit
240 $state->{user
} = $user;
242 $line = <STDIN
>; chomp $line;
243 unless ($line eq "END $request REQUEST") {
244 die "E Do not understand $line -- expecting END $request REQUEST\n";
246 print "I LOVE YOU\n";
247 exit if $request eq 'VERIFICATION'; # cvs login
248 # and now back to our regular programme...
251 # Keep going until the client closes the connection
256 # Check to see if we've seen this method, and call appropriate function.
257 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
259 # use the $methods hash to call the appropriate sub for this command
260 #$log->info("Method : $1");
261 &{$methods->{$1}}($1,$2);
263 # log fatal because we don't understand this function. If this happens
264 # we're fairly screwed because we don't know if the client is expecting
265 # a response. If it is, the client will hang, we'll hang, and the whole
266 # thing will be custard.
267 $log->fatal("Don't understand command $_\n");
268 die("Unknown command $_");
272 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
273 $log->info("--------------- FINISH -----------------");
278 # Magic catchall method.
279 # This is the method that will handle all commands we haven't yet
280 # implemented. It simply sends a warning to the log file indicating a
281 # command that hasn't been implemented has been invoked.
284 my ( $cmd, $data ) = @_;
285 $log->warn("Unhandled command : req_$cmd : $data");
288 # This method invariably succeeds with an empty response.
295 # Response expected: no. Tell the server which CVSROOT to use. Note that
296 # pathname is a local directory and not a fully qualified CVSROOT variable.
297 # pathname must already exist; if creating a new root, use the init
298 # request, not Root. pathname does not include the hostname of the server,
299 # how to access the server, etc.; by the time the CVS protocol is in use,
300 # connection, authentication, etc., are already taken care of. The Root
301 # request must be sent only once, and it must be sent before any requests
302 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
305 my ( $cmd, $data ) = @_;
306 $log->debug("req_Root : $data");
308 unless ($data =~ m
#^/#) {
309 print "error 1 Root must be an absolute pathname\n";
313 my $cvsroot = $state->{'base-path'} || '';
317 if ($state->{CVSROOT
}
318 && ($state->{CVSROOT
} ne $cvsroot)) {
319 print "error 1 Conflicting roots specified\n";
323 $state->{CVSROOT
} = $cvsroot;
325 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
327 if (@
{$state->{allowed_roots
}}) {
329 foreach my $dir (@
{$state->{allowed_roots
}}) {
330 next unless $dir =~ m
#^/#;
332 if ($state->{'strict-paths'}) {
333 if ($ENV{GIT_DIR
} =~ m
#^\Q$dir\E/?$#) {
337 } elsif ($ENV{GIT_DIR
} =~ m
#^\Q$dir\E(/?$|/)#) {
344 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
346 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
351 unless (-d
$ENV{GIT_DIR
} && -e
$ENV{GIT_DIR
}.'HEAD') {
352 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
354 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
358 my @gitvars = `git config -l`;
360 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
362 print "error 1 - problem executing git-config\n";
365 foreach my $line ( @gitvars )
367 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
371 $cfg->{$1}{$2}{$3} = $4;
375 my $enabled = ($cfg->{gitcvs
}{$state->{method
}}{enabled
}
376 || $cfg->{gitcvs
}{enabled
});
377 unless ($state->{'export-all'} ||
378 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
379 print "E GITCVS emulation needs to be enabled on this repo\n";
380 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
382 print "error 1 GITCVS emulation disabled\n";
386 my $logfile = $cfg->{gitcvs
}{$state->{method
}}{logfile
} || $cfg->{gitcvs
}{logfile
};
389 $log->setfile($logfile);
397 # Global_option option \n
398 # Response expected: no. Transmit one of the global options `-q', `-Q',
399 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
400 # variations (such as combining of options) are allowed. For graceful
401 # handling of valid-requests, it is probably better to make new global
402 # options separate requests, rather than trying to add them to this
406 my ( $cmd, $data ) = @_;
407 $log->debug("req_Globaloption : $data");
408 $state->{globaloptions
}{$data} = 1;
411 # Valid-responses request-list \n
412 # Response expected: no. Tell the server what responses the client will
413 # accept. request-list is a space separated list of tokens.
414 sub req_Validresponses
416 my ( $cmd, $data ) = @_;
417 $log->debug("req_Validresponses : $data");
419 # TODO : re-enable this, currently it's not particularly useful
420 #$state->{validresponses} = [ split /\s+/, $data ];
424 # Response expected: yes. Ask the server to send back a Valid-requests
426 sub req_validrequests
428 my ( $cmd, $data ) = @_;
430 $log->debug("req_validrequests");
432 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
433 $log->debug("SEND : ok");
435 print "Valid-requests " . join(" ",keys %$methods) . "\n";
439 # Directory local-directory \n
440 # Additional data: repository \n. Response expected: no. Tell the server
441 # what directory to use. The repository should be a directory name from a
442 # previous server response. Note that this both gives a default for Entry
443 # and Modified and also for ci and the other commands; normal usage is to
444 # send Directory for each directory in which there will be an Entry or
445 # Modified, and then a final Directory for the original directory, then the
446 # command. The local-directory is relative to the top level at which the
447 # command is occurring (i.e. the last Directory which is sent before the
448 # command); to indicate that top level, `.' should be sent for
452 my ( $cmd, $data ) = @_;
454 my $repository = <STDIN
>;
458 $state->{localdir
} = $data;
459 $state->{repository
} = $repository;
460 $state->{path
} = $repository;
461 $state->{path
} =~ s/^\Q$state->{CVSROOT}\E\///;
462 $state->{module
} = $1 if ($state->{path
} =~ s/^(.*?)(\/|$)//);
463 $state->{path
} .= "/" if ( $state->{path
} =~ /\S
/ );
465 $state->{directory
} = $state->{localdir
};
466 $state->{directory
} = "" if ( $state->{directory
} eq "." );
467 $state->{directory
} .= "/" if ( $state->{directory
} =~ /\S
/ );
469 if ( (not defined($state->{prependdir
}) or $state->{prependdir
} eq '') and $state->{localdir
} eq "." and $state->{path
} =~ /\S/ )
471 $log->info("Setting prepend to '$state->{path}'");
472 $state->{prependdir
} = $state->{path
};
473 foreach my $entry ( keys %{$state->{entries
}} )
475 $state->{entries
}{$state->{prependdir
} . $entry} = $state->{entries
}{$entry};
476 delete $state->{entries
}{$entry};
480 if ( defined ( $state->{prependdir
} ) )
482 $log->debug("Prepending '$state->{prependdir}' to state|directory");
483 $state->{directory
} = $state->{prependdir
} . $state->{directory
}
485 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
488 # Entry entry-line \n
489 # Response expected: no. Tell the server what version of a file is on the
490 # local machine. The name in entry-line is a name relative to the directory
491 # most recently specified with Directory. If the user is operating on only
492 # some files in a directory, Entry requests for only those files need be
493 # included. If an Entry request is sent without Modified, Is-modified, or
494 # Unchanged, it means the file is lost (does not exist in the working
495 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
496 # are sent for the same file, Entry must be sent first. For a given file,
497 # one can send Modified, Is-modified, or Unchanged, but not more than one
501 my ( $cmd, $data ) = @_;
503 #$log->debug("req_Entry : $data");
505 my @data = split(/\//, $data);
507 $state->{entries
}{$state->{directory
}.$data[1]} = {
508 revision
=> $data[2],
509 conflict
=> $data[3],
511 tag_or_date
=> $data[5],
514 $log->info("Received entry line '$data' => '" . $state->{directory
} . $data[1] . "'");
517 # Questionable filename \n
518 # Response expected: no. Additional data: no. Tell the server to check
519 # whether filename should be ignored, and if not, next time the server
520 # sends responses, send (in a M response) `?' followed by the directory and
521 # filename. filename must not contain `/'; it needs to be a file in the
522 # directory named by the most recent Directory request.
525 my ( $cmd, $data ) = @_;
527 $log->debug("req_Questionable : $data");
528 $state->{entries
}{$state->{directory
}.$data}{questionable
} = 1;
532 # Response expected: yes. Add a file or directory. This uses any previous
533 # Argument, Directory, Entry, or Modified requests, if they have been sent.
534 # The last Directory sent specifies the working directory at the time of
535 # the operation. To add a directory, send the directory to be added using
536 # Directory and Argument requests.
539 my ( $cmd, $data ) = @_;
543 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
546 argsfromdir
($updater);
550 foreach my $filename ( @
{$state->{args
}} )
552 $filename = filecleanup
($filename);
554 my $meta = $updater->getmeta($filename);
555 my $wrev = revparse
($filename);
557 if ($wrev && $meta && ($wrev < 0))
559 # previously removed file, add back
560 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
562 print "MT +updated\n";
563 print "MT text U \n";
564 print "MT fname $filename\n";
565 print "MT newline\n";
566 print "MT -updated\n";
568 unless ( $state->{globaloptions
}{-n
} )
570 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
572 print "Created $dirpart\n";
573 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
575 # this is an "entries" line
576 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
577 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
578 print "/$filepart/1.$meta->{revision}//$kopts/\n";
580 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
581 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
583 transmitfile
($meta->{filehash
});
589 unless ( defined ( $state->{entries
}{$filename}{modified_filename
} ) )
591 print "E cvs add: nothing known about `$filename'\n";
594 # TODO : check we're not squashing an already existing file
595 if ( defined ( $state->{entries
}{$filename}{revision
} ) )
597 print "E cvs add: `$filename' has already been entered\n";
601 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
603 print "E cvs add: scheduling file `$filename' for addition\n";
605 print "Checked-in $dirpart\n";
607 my $kopts = kopts_from_path
($filename,"file",
608 $state->{entries
}{$filename}{modified_filename
});
609 print "/$filepart/0//$kopts/\n";
611 my $requestedKopts = $state->{opt
}{k
};
612 if(defined($requestedKopts))
614 $requestedKopts = "-k$requestedKopts";
618 $requestedKopts = "";
620 if( $kopts ne $requestedKopts )
622 $log->warn("Ignoring requested -k='$requestedKopts'"
623 . " for '$filename'; detected -k='$kopts' instead");
624 #TODO: Also have option to send warning to user?
630 if ( $addcount == 1 )
632 print "E cvs add: use `cvs commit' to add this file permanently\n";
634 elsif ( $addcount > 1 )
636 print "E cvs add: use `cvs commit' to add these files permanently\n";
643 # Response expected: yes. Remove a file. This uses any previous Argument,
644 # Directory, Entry, or Modified requests, if they have been sent. The last
645 # Directory sent specifies the working directory at the time of the
646 # operation. Note that this request does not actually do anything to the
647 # repository; the only effect of a successful remove request is to supply
648 # the client with a new entries line containing `-' to indicate a removed
649 # file. In fact, the client probably could perform this operation without
650 # contacting the server, although using remove may cause the server to
651 # perform a few more checks. The client sends a subsequent ci request to
652 # actually record the removal in the repository.
655 my ( $cmd, $data ) = @_;
659 # Grab a handle to the SQLite db and do any necessary updates
660 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
663 #$log->debug("add state : " . Dumper($state));
667 foreach my $filename ( @
{$state->{args
}} )
669 $filename = filecleanup
($filename);
671 if ( defined ( $state->{entries
}{$filename}{unchanged
} ) or defined ( $state->{entries
}{$filename}{modified_filename
} ) )
673 print "E cvs remove: file `$filename' still in working directory\n";
677 my $meta = $updater->getmeta($filename);
678 my $wrev = revparse
($filename);
680 unless ( defined ( $wrev ) )
682 print "E cvs remove: nothing known about `$filename'\n";
686 if ( defined($wrev) and $wrev < 0 )
688 print "E cvs remove: file `$filename' already scheduled for removal\n";
692 unless ( $wrev == $meta->{revision
} )
694 # TODO : not sure if the format of this message is quite correct.
695 print "E cvs remove: Up to date check failed for `$filename'\n";
700 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
702 print "E cvs remove: scheduling `$filename' for removal\n";
704 print "Checked-in $dirpart\n";
706 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
707 print "/$filepart/-1.$wrev//$kopts/\n";
714 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
716 elsif ( $rmcount > 1 )
718 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
724 # Modified filename \n
725 # Response expected: no. Additional data: mode, \n, file transmission. Send
726 # the server a copy of one locally modified file. filename is a file within
727 # the most recent directory sent with Directory; it must not contain `/'.
728 # If the user is operating on only some files in a directory, only those
729 # files need to be included. This can also be sent without Entry, if there
730 # is no entry for the file.
733 my ( $cmd, $data ) = @_;
737 or (print "E end of file reading mode for $data\n"), return;
741 or (print "E end of file reading size of $data\n"), return;
744 # Grab config information
745 my $blocksize = 8192;
746 my $bytesleft = $size;
749 # Get a filehandle/name to write it to
750 my ( $fh, $filename ) = tempfile
( DIR
=> $TEMP_DIR );
752 # Loop over file data writing out to temporary file.
755 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
756 read STDIN
, $tmp, $blocksize;
758 $bytesleft -= $blocksize;
762 or (print "E failed to write temporary, $filename: $!\n"), return;
764 # Ensure we have something sensible for the file mode
765 if ( $mode =~ /u=(\w+)/ )
772 # Save the file data in $state
773 $state->{entries
}{$state->{directory
}.$data}{modified_filename
} = $filename;
774 $state->{entries
}{$state->{directory
}.$data}{modified_mode
} = $mode;
775 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} = `git hash-object $filename`;
776 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} =~ s/\s.*$//s;
778 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
781 # Unchanged filename \n
782 # Response expected: no. Tell the server that filename has not been
783 # modified in the checked out directory. The filename is a file within the
784 # most recent directory sent with Directory; it must not contain `/'.
787 my ( $cmd, $data ) = @_;
789 $state->{entries
}{$state->{directory
}.$data}{unchanged
} = 1;
791 #$log->debug("req_Unchanged : $data");
795 # Response expected: no. Save argument for use in a subsequent command.
796 # Arguments accumulate until an argument-using command is given, at which
797 # point they are forgotten.
799 # Response expected: no. Append \n followed by text to the current argument
803 my ( $cmd, $data ) = @_;
805 # Argumentx means: append to last Argument (with a newline in front)
807 $log->debug("$cmd : $data");
809 if ( $cmd eq 'Argumentx') {
810 ${$state->{arguments
}}[$#{$state->{arguments}}] .= "\n" . $data;
812 push @
{$state->{arguments
}}, $data;
817 # Response expected: yes. Expand the modules which are specified in the
818 # arguments. Returns the data in Module-expansion responses. Note that the
819 # server can assume that this is checkout or export, not rtag or rdiff; the
820 # latter do not access the working directory and thus have no need to
821 # expand modules on the client side. Expand may not be the best word for
822 # what this request does. It does not necessarily tell you all the files
823 # contained in a module, for example. Basically it is a way of telling you
824 # which working directories the server needs to know about in order to
825 # handle a checkout of the specified modules. For example, suppose that the
826 # server has a module defined by
827 # aliasmodule -a 1dir
828 # That is, one can check out aliasmodule and it will take 1dir in the
829 # repository and check it out to 1dir in the working directory. Now suppose
830 # the client already has this module checked out and is planning on using
831 # the co request to update it. Without using expand-modules, the client
832 # would have two bad choices: it could either send information about all
833 # working directories under the current directory, which could be
834 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
835 # stands for 1dir, and neglect to send information for 1dir, which would
836 # lead to incorrect operation. With expand-modules, the client would first
837 # ask for the module to be expanded:
838 sub req_expandmodules
840 my ( $cmd, $data ) = @_;
844 $log->debug("req_expandmodules : " . ( defined($data) ?
$data : "[NULL]" ) );
846 unless ( ref $state->{arguments
} eq "ARRAY" )
852 foreach my $module ( @
{$state->{arguments
}} )
854 $log->debug("SEND : Module-expansion $module");
855 print "Module-expansion $module\n";
863 # Response expected: yes. Get files from the repository. This uses any
864 # previous Argument, Directory, Entry, or Modified requests, if they have
865 # been sent. Arguments to this command are module names; the client cannot
866 # know what directories they correspond to except by (1) just sending the
867 # co request, and then seeing what directory names the server sends back in
868 # its responses, and (2) the expand-modules request.
871 my ( $cmd, $data ) = @_;
875 # Provide list of modules, if -c was used.
876 if (exists $state->{opt
}{c
}) {
877 my $showref = `git show-ref --heads`;
878 for my $line (split '\n', $showref) {
879 if ( $line =~ m
% refs
/heads/(.*)$% ) {
887 my $module = $state->{args
}[0];
888 $state->{module
} = $module;
889 my $checkout_path = $module;
891 # use the user specified directory if we're given it
892 $checkout_path = $state->{opt
}{d
} if ( exists ( $state->{opt
}{d
} ) );
894 $log->debug("req_co : " . ( defined($data) ?
$data : "[NULL]" ) );
896 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
898 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
900 # Grab a handle to the SQLite db and do any necessary updates
901 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $module, $log);
904 $checkout_path =~ s
|/$||; # get rid of trailing slashes
906 # Eclipse seems to need the Clear-sticky command
907 # to prepare the 'Entries' file for the new directory.
908 print "Clear-sticky $checkout_path/\n";
909 print $state->{CVSROOT
} . "/$module/\n";
910 print "Clear-static-directory $checkout_path/\n";
911 print $state->{CVSROOT
} . "/$module/\n";
912 print "Clear-sticky $checkout_path/\n"; # yes, twice
913 print $state->{CVSROOT
} . "/$module/\n";
914 print "Template $checkout_path/\n";
915 print $state->{CVSROOT
} . "/$module/\n";
918 # instruct the client that we're checking out to $checkout_path
919 print "E cvs checkout: Updating $checkout_path\n";
926 my ($dir, $repodir, $remotedir, $seendirs) = @_;
927 my $parent = dirname
($dir);
930 $remotedir =~ s
|/+$||;
932 $log->debug("announcedir $dir, $repodir, $remotedir" );
934 if ($parent eq '.' || $parent eq './') {
937 # recurse to announce unseen parents first
938 if (length($parent) && !exists($seendirs->{$parent})) {
939 prepdir
($parent, $repodir, $remotedir, $seendirs);
941 # Announce that we are going to modify at the parent level
943 print "E cvs checkout: Updating $remotedir/$parent\n";
945 print "E cvs checkout: Updating $remotedir\n";
947 print "Clear-sticky $remotedir/$parent/\n";
948 print "$repodir/$parent/\n";
950 print "Clear-static-directory $remotedir/$dir/\n";
951 print "$repodir/$dir/\n";
952 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
953 print "$repodir/$parent/\n";
954 print "Template $remotedir/$dir/\n";
955 print "$repodir/$dir/\n";
958 $seendirs->{$dir} = 1;
961 foreach my $git ( @
{$updater->gethead} )
963 # Don't want to check out deleted files
964 next if ( $git->{filehash
} eq "deleted" );
966 my $fullName = $git->{name
};
967 ( $git->{name
}, $git->{dir
} ) = filenamesplit
($git->{name
});
969 if (length($git->{dir
}) && $git->{dir
} ne './'
970 && $git->{dir
} ne $lastdir ) {
971 unless (exists($seendirs{$git->{dir
}})) {
972 prepdir
($git->{dir
}, $state->{CVSROOT
} . "/$module/",
973 $checkout_path, \
%seendirs);
974 $lastdir = $git->{dir
};
975 $seendirs{$git->{dir
}} = 1;
977 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
980 # modification time of this file
981 print "Mod-time $git->{modified}\n";
983 # print some information to the client
984 if ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" )
986 print "M U $checkout_path/$git->{dir}$git->{name}\n";
988 print "M U $checkout_path/$git->{name}\n";
991 # instruct client we're sending a file to put in this path
992 print "Created $checkout_path/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "\n";
994 print $state->{CVSROOT
} . "/$module/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "$git->{name}\n";
996 # this is an "entries" line
997 my $kopts = kopts_from_path
($fullName,"sha1",$git->{filehash
});
998 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
1000 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1003 transmitfile
($git->{filehash
});
1012 # Response expected: yes. Actually do a cvs update command. This uses any
1013 # previous Argument, Directory, Entry, or Modified requests, if they have
1014 # been sent. The last Directory sent specifies the working directory at the
1015 # time of the operation. The -I option is not used--files which the client
1016 # can decide whether to ignore are not mentioned and the client sends the
1017 # Questionable request for others.
1020 my ( $cmd, $data ) = @_;
1022 $log->debug("req_update : " . ( defined($data) ?
$data : "[NULL]" ));
1027 # It may just be a client exploring the available heads/modules
1028 # in that case, list them as top level directories and leave it
1029 # at that. Eclipse uses this technique to offer you a list of
1030 # projects (heads in this case) to checkout.
1032 if ($state->{module
} eq '') {
1033 my $showref = `git show-ref --heads`;
1034 print "E cvs update: Updating .\n";
1035 for my $line (split '\n', $showref) {
1036 if ( $line =~ m
% refs
/heads/(.*)$% ) {
1037 print "E cvs update: New directory `$1'\n";
1045 # Grab a handle to the SQLite db and do any necessary updates
1046 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1050 argsfromdir
($updater);
1052 #$log->debug("update state : " . Dumper($state));
1054 my $last_dirname = "///";
1056 # foreach file specified on the command line ...
1057 foreach my $filename ( @
{$state->{args
}} )
1059 $filename = filecleanup
($filename);
1061 $log->debug("Processing file $filename");
1063 unless ( $state->{globaloptions
}{-Q
} || $state->{globaloptions
}{-q
} )
1065 my $cur_dirname = dirname
($filename);
1066 if ( $cur_dirname ne $last_dirname )
1068 $last_dirname = $cur_dirname;
1069 if ( $cur_dirname eq "" )
1073 print "E cvs update: Updating $cur_dirname\n";
1077 # if we have a -C we should pretend we never saw modified stuff
1078 if ( exists ( $state->{opt
}{C
} ) )
1080 delete $state->{entries
}{$filename}{modified_hash
};
1081 delete $state->{entries
}{$filename}{modified_filename
};
1082 $state->{entries
}{$filename}{unchanged
} = 1;
1086 if ( defined($state->{opt
}{r
}) and $state->{opt
}{r
} =~ /^1\.(\d+)/ )
1088 $meta = $updater->getmeta($filename, $1);
1090 $meta = $updater->getmeta($filename);
1093 # If -p was given, "print" the contents of the requested revision.
1094 if ( exists ( $state->{opt
}{p
} ) ) {
1095 if ( defined ( $meta->{revision
} ) ) {
1096 $log->info("Printing '$filename' revision " . $meta->{revision
});
1098 transmitfile
($meta->{filehash
}, { print => 1 });
1104 if ( ! defined $meta )
1113 my $oldmeta = $meta;
1115 my $wrev = revparse
($filename);
1117 # If the working copy is an old revision, lets get that version too for comparison.
1118 if ( defined($wrev) and $wrev != $meta->{revision
} )
1120 $oldmeta = $updater->getmeta($filename, $wrev);
1123 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1125 # Files are up to date if the working copy and repo copy have the same revision,
1126 # and the working copy is unmodified _and_ the user hasn't specified -C
1127 next if ( defined ( $wrev )
1128 and defined($meta->{revision
})
1129 and $wrev == $meta->{revision
}
1130 and $state->{entries
}{$filename}{unchanged
}
1131 and not exists ( $state->{opt
}{C
} ) );
1133 # If the working copy and repo copy have the same revision,
1134 # but the working copy is modified, tell the client it's modified
1135 if ( defined ( $wrev )
1136 and defined($meta->{revision
})
1137 and $wrev == $meta->{revision
}
1138 and defined($state->{entries
}{$filename}{modified_hash
})
1139 and not exists ( $state->{opt
}{C
} ) )
1141 $log->info("Tell the client the file is modified");
1142 print "MT text M \n";
1143 print "MT fname $filename\n";
1144 print "MT newline\n";
1148 if ( $meta->{filehash
} eq "deleted" )
1150 # TODO: If it has been modified in the sandbox, error out
1151 # with the appropriate message, rather than deleting a modified
1154 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1156 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1158 print "E cvs update: `$filename' is no longer in the repository\n";
1159 # Don't want to actually _DO_ the update if -n specified
1160 unless ( $state->{globaloptions
}{-n
} ) {
1161 print "Removed $dirpart\n";
1162 print "$filepart\n";
1165 elsif ( not defined ( $state->{entries
}{$filename}{modified_hash
} )
1166 or $state->{entries
}{$filename}{modified_hash
} eq $oldmeta->{filehash
}
1167 or $meta->{filehash
} eq 'added' )
1169 # normal update, just send the new revision (either U=Update,
1170 # or A=Add, or R=Remove)
1171 if ( defined($wrev) && $wrev < 0 )
1173 $log->info("Tell the client the file is scheduled for removal");
1174 print "MT text R \n";
1175 print "MT fname $filename\n";
1176 print "MT newline\n";
1179 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision
}) || $meta->{revision
} == 0) )
1181 $log->info("Tell the client the file is scheduled for addition");
1182 print "MT text A \n";
1183 print "MT fname $filename\n";
1184 print "MT newline\n";
1189 $log->info("Updating '$filename' to ".$meta->{revision
});
1190 print "MT +updated\n";
1191 print "MT text U \n";
1192 print "MT fname $filename\n";
1193 print "MT newline\n";
1194 print "MT -updated\n";
1197 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1199 # Don't want to actually _DO_ the update if -n specified
1200 unless ( $state->{globaloptions
}{-n
} )
1202 if ( defined ( $wrev ) )
1204 # instruct client we're sending a file to put in this path as a replacement
1205 print "Update-existing $dirpart\n";
1206 $log->debug("Updating existing file 'Update-existing $dirpart'");
1208 # instruct client we're sending a file to put in this path as a new file
1209 print "Clear-static-directory $dirpart\n";
1210 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
1211 print "Clear-sticky $dirpart\n";
1212 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
1214 $log->debug("Creating new file 'Created $dirpart'");
1215 print "Created $dirpart\n";
1217 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1219 # this is an "entries" line
1220 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1221 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1222 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1225 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1226 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1229 transmitfile
($meta->{filehash
});
1232 $log->info("Updating '$filename'");
1233 my ( $filepart, $dirpart ) = filenamesplit
($meta->{name
},1);
1235 my $mergeDir = setupTmpDir
();
1237 my $file_local = $filepart . ".mine";
1238 my $mergedFile = "$mergeDir/$file_local";
1239 system("ln","-s",$state->{entries
}{$filename}{modified_filename
}, $file_local);
1240 my $file_old = $filepart . "." . $oldmeta->{revision
};
1241 transmitfile
($oldmeta->{filehash
}, { targetfile
=> $file_old });
1242 my $file_new = $filepart . "." . $meta->{revision
};
1243 transmitfile
($meta->{filehash
}, { targetfile
=> $file_new });
1245 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1246 $log->info("Merging $file_local, $file_old, $file_new");
1247 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1249 $log->debug("Temporary directory for merge is $mergeDir");
1251 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1258 $log->info("Merged successfully");
1259 print "M M $filename\n";
1260 $log->debug("Merged $dirpart");
1262 # Don't want to actually _DO_ the update if -n specified
1263 unless ( $state->{globaloptions
}{-n
} )
1265 print "Merged $dirpart\n";
1266 $log->debug($state->{CVSROOT
} . "/$state->{module}/$filename");
1267 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1268 my $kopts = kopts_from_path
("$dirpart/$filepart",
1269 "file",$mergedFile);
1270 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1271 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1274 elsif ( $return == 1 )
1276 $log->info("Merged with conflicts");
1277 print "E cvs update: conflicts found in $filename\n";
1278 print "M C $filename\n";
1280 # Don't want to actually _DO_ the update if -n specified
1281 unless ( $state->{globaloptions
}{-n
} )
1283 print "Merged $dirpart\n";
1284 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1285 my $kopts = kopts_from_path
("$dirpart/$filepart",
1286 "file",$mergedFile);
1287 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1292 $log->warn("Merge failed");
1296 # Don't want to actually _DO_ the update if -n specified
1297 unless ( $state->{globaloptions
}{-n
} )
1300 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1301 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1303 # transmit file, format is single integer on a line by itself (file
1304 # size) followed by the file contents
1305 # TODO : we should copy files in blocks
1306 my $data = `cat $mergedFile`;
1307 $log->debug("File size : " . length($data));
1308 print length($data) . "\n";
1320 my ( $cmd, $data ) = @_;
1324 #$log->debug("State : " . Dumper($state));
1326 $log->info("req_ci : " . ( defined($data) ?
$data : "[NULL]" ));
1328 if ( $state->{method
} eq 'pserver' and $state->{user
} eq 'anonymous' )
1330 print "error 1 anonymous user cannot commit via pserver\n";
1335 if ( -e
$state->{CVSROOT
} . "/index" )
1337 $log->warn("file 'index' already exists in the git repository");
1338 print "error 1 Index already exists in git repo\n";
1343 # Grab a handle to the SQLite db and do any necessary updates
1344 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1347 # Remember where the head was at the beginning.
1348 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1350 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1351 print "error 1 pserver cannot find the current HEAD of module";
1356 setupWorkTree
($parenthash);
1358 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1360 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1362 my @committedfiles = ();
1365 # foreach file specified on the command line ...
1366 foreach my $filename ( @
{$state->{args
}} )
1368 my $committedfile = $filename;
1369 $filename = filecleanup
($filename);
1371 next unless ( exists $state->{entries
}{$filename}{modified_filename
} or not $state->{entries
}{$filename}{unchanged
} );
1373 my $meta = $updater->getmeta($filename);
1374 $oldmeta{$filename} = $meta;
1376 my $wrev = revparse
($filename);
1378 my ( $filepart, $dirpart ) = filenamesplit
($filename);
1380 # do a checkout of the file if it is part of this tree
1382 system('git', 'checkout-index', '-f', '-u', $filename);
1384 die "Error running git-checkout-index -f -u $filename : $!";
1390 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1391 $addflag = 1 unless ( -e
$filename );
1393 # Do up to date checking
1394 unless ( $addflag or $wrev == $meta->{revision
} or ( $rmflag and -$wrev == $meta->{revision
} ) )
1396 # fail everything if an up to date check fails
1397 print "error 1 Up to date check failed for $filename\n";
1402 push @committedfiles, $committedfile;
1403 $log->info("Committing $filename");
1405 system("mkdir","-p",$dirpart) unless ( -d
$dirpart );
1409 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1410 rename $state->{entries
}{$filename}{modified_filename
},$filename;
1412 # Calculate modes to remove
1414 foreach ( qw
(r w x
) ) { $invmode .= $_ unless ( $state->{entries
}{$filename}{modified_mode
} =~ /$_/ ); }
1416 $log->debug("chmod u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode . " $filename");
1417 system("chmod","u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode, $filename);
1422 $log->info("Removing file '$filename'");
1424 system("git", "update-index", "--remove", $filename);
1428 $log->info("Adding file '$filename'");
1429 system("git", "update-index", "--add", $filename);
1431 $log->info("Updating file '$filename'");
1432 system("git", "update-index", $filename);
1436 unless ( scalar(@committedfiles) > 0 )
1438 print "E No files to commit\n";
1444 my $treehash = `git write-tree`;
1447 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1449 # write our commit message out if we have one ...
1450 my ( $msg_fh, $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1451 print $msg_fh $state->{opt
}{m
};# if ( exists ( $state->{opt}{m} ) );
1452 if ( defined ( $cfg->{gitcvs
}{commitmsgannotation
} ) ) {
1453 if ($cfg->{gitcvs
}{commitmsgannotation
} !~ /^\s*$/ ) {
1454 print $msg_fh "\n\n".$cfg->{gitcvs
}{commitmsgannotation
}."\n"
1457 print $msg_fh "\n\nvia git-CVS emulator\n";
1461 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1463 $log->info("Commit hash : $commithash");
1465 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1467 $log->warn("Commit failed (Invalid commit hash)");
1468 print "error 1 Commit failed (unknown reason)\n";
1473 ### Emulate git-receive-pack by running hooks/update
1474 my @hook = ( $ENV{GIT_DIR
}.'hooks/update', "refs/heads/$state->{module}",
1475 $parenthash, $commithash );
1477 unless( system( @hook ) == 0 )
1479 $log->warn("Commit failed (update hook declined to update ref)");
1480 print "error 1 Commit failed (update hook declined)\n";
1487 if (system(qw(git update-ref -m), "cvsserver ci",
1488 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1489 $log->warn("update-ref for $state->{module} failed.");
1490 print "error 1 Cannot commit -- update first\n";
1495 ### Emulate git-receive-pack by running hooks/post-receive
1496 my $hook = $ENV{GIT_DIR
}.'hooks/post-receive';
1498 open(my $pipe, "| $hook") || die "can't fork $!";
1500 local $SIG{PIPE
} = sub { die 'pipe broke' };
1502 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1504 close $pipe || die "bad pipe: $! $?";
1509 ### Then hooks/post-update
1510 $hook = $ENV{GIT_DIR
}.'hooks/post-update';
1512 system($hook, "refs/heads/$state->{module}");
1515 # foreach file specified on the command line ...
1516 foreach my $filename ( @committedfiles )
1518 $filename = filecleanup
($filename);
1520 my $meta = $updater->getmeta($filename);
1521 unless (defined $meta->{revision
}) {
1522 $meta->{revision
} = 1;
1525 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
1527 $log->debug("Checked-in $dirpart : $filename");
1529 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1530 if ( defined $meta->{filehash
} && $meta->{filehash
} eq "deleted" )
1532 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1533 print "Remove-entry $dirpart\n";
1534 print "$filename\n";
1536 if ($meta->{revision
} == 1) {
1537 print "M initial revision: 1.1\n";
1539 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1541 print "Checked-in $dirpart\n";
1542 print "$filename\n";
1543 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1544 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1554 my ( $cmd, $data ) = @_;
1558 $log->info("req_status : " . ( defined($data) ?
$data : "[NULL]" ));
1559 #$log->debug("status state : " . Dumper($state));
1561 # Grab a handle to the SQLite db and do any necessary updates
1563 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1566 # if no files were specified, we need to work out what files we should
1567 # be providing status on ...
1568 argsfromdir
($updater);
1570 # foreach file specified on the command line ...
1571 foreach my $filename ( @
{$state->{args
}} )
1573 $filename = filecleanup
($filename);
1575 if ( exists($state->{opt
}{l
}) &&
1576 index($filename, '/', length($state->{prependdir
})) >= 0 )
1581 my $meta = $updater->getmeta($filename);
1582 my $oldmeta = $meta;
1584 my $wrev = revparse
($filename);
1586 # If the working copy is an old revision, lets get that
1587 # version too for comparison.
1588 if ( defined($wrev) and $wrev != $meta->{revision
} )
1590 $oldmeta = $updater->getmeta($filename, $wrev);
1593 # TODO : All possible statuses aren't yet implemented
1595 # Files are up to date if the working copy and repo copy have
1596 # the same revision, and the working copy is unmodified
1597 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1598 $wrev == $meta->{revision
} and
1599 ( ( $state->{entries
}{$filename}{unchanged
} and
1600 ( not defined ( $state->{entries
}{$filename}{conflict
} ) or
1601 $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) ) or
1602 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1603 $state->{entries
}{$filename}{modified_hash
} eq
1604 $meta->{filehash
} ) ) )
1606 $status = "Up-to-date";
1609 # Need checkout if the working copy has an older revision than
1610 # the repo copy, and the working copy is unmodified
1611 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1612 $meta->{revision
} > $wrev and
1613 ( $state->{entries
}{$filename}{unchanged
} or
1614 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1615 $state->{entries
}{$filename}{modified_hash
} eq
1616 $oldmeta->{filehash
} ) ) )
1618 $status ||= "Needs Checkout";
1621 # Need checkout if it exists in the repo but doesn't have a working
1623 if ( not defined ( $wrev ) and defined ( $meta->{revision
} ) )
1625 $status ||= "Needs Checkout";
1628 # Locally modified if working copy and repo copy have the
1629 # same revision but there are local changes
1630 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1631 $wrev == $meta->{revision
} and
1632 $state->{entries
}{$filename}{modified_filename
} )
1634 $status ||= "Locally Modified";
1637 # Needs Merge if working copy revision is less than repo copy
1638 # and there are local changes
1639 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1640 $meta->{revision
} > $wrev and
1641 $state->{entries
}{$filename}{modified_filename
} )
1643 $status ||= "Needs Merge";
1646 if ( defined ( $state->{entries
}{$filename}{revision
} ) and
1647 not defined ( $meta->{revision
} ) )
1649 $status ||= "Locally Added";
1651 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1652 -$wrev == $meta->{revision
} )
1654 $status ||= "Locally Removed";
1656 if ( defined ( $state->{entries
}{$filename}{conflict
} ) and
1657 $state->{entries
}{$filename}{conflict
} =~ /^\+=/ )
1659 $status ||= "Unresolved Conflict";
1663 $status ||= "File had conflicts on merge";
1666 $status ||= "Unknown";
1668 my ($filepart) = filenamesplit
($filename);
1670 print "M =======" . ( "=" x
60 ) . "\n";
1671 print "M File: $filepart\tStatus: $status\n";
1672 if ( defined($state->{entries
}{$filename}{revision
}) )
1674 print "M Working revision:\t" .
1675 $state->{entries
}{$filename}{revision
} . "\n";
1677 print "M Working revision:\tNo entry for $filename\n";
1679 if ( defined($meta->{revision
}) )
1681 print "M Repository revision:\t1." .
1683 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1684 print "M Sticky Tag:\t\t(none)\n";
1685 print "M Sticky Date:\t\t(none)\n";
1686 print "M Sticky Options:\t\t(none)\n";
1688 print "M Repository revision:\tNo revision control file\n";
1698 my ( $cmd, $data ) = @_;
1702 $log->debug("req_diff : " . ( defined($data) ?
$data : "[NULL]" ));
1703 #$log->debug("status state : " . Dumper($state));
1705 my ($revision1, $revision2);
1706 if ( defined ( $state->{opt
}{r
} ) and ref $state->{opt
}{r
} eq "ARRAY" )
1708 $revision1 = $state->{opt
}{r
}[0];
1709 $revision2 = $state->{opt
}{r
}[1];
1711 $revision1 = $state->{opt
}{r
};
1714 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1715 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1717 $log->debug("Diffing revisions " .
1718 ( defined($revision1) ?
$revision1 : "[NULL]" ) .
1719 " and " . ( defined($revision2) ?
$revision2 : "[NULL]" ) );
1721 # Grab a handle to the SQLite db and do any necessary updates
1723 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1726 # if no files were specified, we need to work out what files we should
1727 # be providing status on ...
1728 argsfromdir
($updater);
1730 # foreach file specified on the command line ...
1731 foreach my $filename ( @
{$state->{args
}} )
1733 $filename = filecleanup
($filename);
1735 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1737 my $wrev = revparse
($filename);
1739 # We need _something_ to diff against
1740 next unless ( defined ( $wrev ) );
1742 # if we have a -r switch, use it
1743 if ( defined ( $revision1 ) )
1745 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1746 $meta1 = $updater->getmeta($filename, $revision1);
1747 unless ( defined ( $meta1 ) and $meta1->{filehash
} ne "deleted" )
1749 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1752 transmitfile
($meta1->{filehash
}, { targetfile
=> $file1 });
1754 # otherwise we just use the working copy revision
1757 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1758 $meta1 = $updater->getmeta($filename, $wrev);
1759 transmitfile
($meta1->{filehash
}, { targetfile
=> $file1 });
1762 # if we have a second -r switch, use it too
1763 if ( defined ( $revision2 ) )
1765 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1766 $meta2 = $updater->getmeta($filename, $revision2);
1768 unless ( defined ( $meta2 ) and $meta2->{filehash
} ne "deleted" )
1770 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1774 transmitfile
($meta2->{filehash
}, { targetfile
=> $file2 });
1776 # otherwise we just use the working copy
1779 $file2 = $state->{entries
}{$filename}{modified_filename
};
1782 # if we have been given -r, and we don't have a $file2 yet, lets
1784 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1786 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1787 $meta2 = $updater->getmeta($filename, $wrev);
1788 transmitfile
($meta2->{filehash
}, { targetfile
=> $file2 });
1791 # We need to have retrieved something useful
1792 next unless ( defined ( $meta1 ) );
1794 # Files to date if the working copy and repo copy have the same
1795 # revision, and the working copy is unmodified
1796 if ( not defined ( $meta2 ) and $wrev == $meta1->{revision
} and
1797 ( ( $state->{entries
}{$filename}{unchanged
} and
1798 ( not defined ( $state->{entries
}{$filename}{conflict
} ) or
1799 $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) ) or
1800 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1801 $state->{entries
}{$filename}{modified_hash
} eq
1802 $meta1->{filehash
} ) ) )
1807 # Apparently we only show diffs for locally modified files
1808 unless ( defined($meta2) or
1809 defined ( $state->{entries
}{$filename}{modified_filename
} ) )
1814 print "M Index: $filename\n";
1815 print "M =======" . ( "=" x
60 ) . "\n";
1816 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1817 if ( defined ( $meta1 ) )
1819 print "M retrieving revision 1.$meta1->{revision}\n"
1821 if ( defined ( $meta2 ) )
1823 print "M retrieving revision 1.$meta2->{revision}\n"
1826 foreach my $opt ( keys %{$state->{opt
}} )
1828 if ( ref $state->{opt
}{$opt} eq "ARRAY" )
1830 foreach my $value ( @
{$state->{opt
}{$opt}} )
1832 print "-$opt $value ";
1836 if ( defined ( $state->{opt
}{$opt} ) )
1838 print "$state->{opt}{$opt} "
1842 print "$filename\n";
1844 $log->info("Diffing $filename -r $meta1->{revision} -r " .
1845 ( $meta2->{revision
} or "workingcopy" ));
1847 ( $fh, $filediff ) = tempfile
( DIR
=> $TEMP_DIR );
1849 if ( exists $state->{opt
}{u
} )
1851 system("diff -u -L '$filename revision 1.$meta1->{revision}'" .
1853 ( defined($meta2->{revision
}) ?
1854 "revision 1.$meta2->{revision}" :
1856 "' $file1 $file2 > $filediff" );
1858 system("diff $file1 $file2 > $filediff");
1873 my ( $cmd, $data ) = @_;
1877 $log->debug("req_log : " . ( defined($data) ?
$data : "[NULL]" ));
1878 #$log->debug("log state : " . Dumper($state));
1880 my ( $minrev, $maxrev );
1881 if ( defined ( $state->{opt
}{r
} ) and
1882 $state->{opt
}{r
} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1887 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1888 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1889 $minrev++ if ( defined($minrev) and $control eq "::" );
1892 # Grab a handle to the SQLite db and do any necessary updates
1894 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1897 # if no files were specified, we need to work out what files we
1898 # should be providing status on ...
1899 argsfromdir
($updater);
1901 # foreach file specified on the command line ...
1902 foreach my $filename ( @
{$state->{args
}} )
1904 $filename = filecleanup
($filename);
1906 my $headmeta = $updater->getmeta($filename);
1908 my $revisions = $updater->getlog($filename);
1909 my $totalrevisions = scalar(@
$revisions);
1911 if ( defined ( $minrev ) )
1913 $log->debug("Removing revisions less than $minrev");
1914 while ( scalar(@
$revisions) > 0 and
1915 $revisions->[-1]{revision
} < $minrev )
1920 if ( defined ( $maxrev ) )
1922 $log->debug("Removing revisions greater than $maxrev");
1923 while ( scalar(@
$revisions) > 0 and
1924 $revisions->[0]{revision
} > $maxrev )
1930 next unless ( scalar(@
$revisions) );
1933 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1934 print "M Working file: $filename\n";
1935 print "M head: 1.$headmeta->{revision}\n";
1936 print "M branch:\n";
1937 print "M locks: strict\n";
1938 print "M access list:\n";
1939 print "M symbolic names:\n";
1940 print "M keyword substitution: kv\n";
1941 print "M total revisions: $totalrevisions;\tselected revisions: " .
1942 scalar(@
$revisions) . "\n";
1943 print "M description:\n";
1945 foreach my $revision ( @
$revisions )
1947 print "M ----------------------------\n";
1948 print "M revision 1.$revision->{revision}\n";
1949 # reformat the date for log output
1950 if ( $revision->{modified
} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
1951 defined($DATE_LIST->{$2}) )
1953 $revision->{modified
} = sprintf('%04d/%02d/%02d %s',
1954 $3, $DATE_LIST->{$2}, $1, $4 );
1956 $revision->{author
} = cvs_author
($revision->{author
});
1957 print "M date: $revision->{modified};" .
1958 " author: $revision->{author}; state: " .
1959 ( $revision->{filehash
} eq "deleted" ?
"dead" : "Exp" ) .
1962 $commitmessage = $updater->commitmessage($revision->{commithash
});
1963 $commitmessage =~ s/^/M /mg;
1964 print $commitmessage . "\n";
1966 print "M =======" . ( "=" x
70 ) . "\n";
1974 my ( $cmd, $data ) = @_;
1976 argsplit
("annotate");
1978 $log->info("req_annotate : " . ( defined($data) ?
$data : "[NULL]" ));
1979 #$log->debug("status state : " . Dumper($state));
1981 # Grab a handle to the SQLite db and do any necessary updates
1982 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1985 # if no files were specified, we need to work out what files we should be providing annotate on ...
1986 argsfromdir
($updater);
1988 # we'll need a temporary checkout dir
1991 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1993 # foreach file specified on the command line ...
1994 foreach my $filename ( @
{$state->{args
}} )
1996 $filename = filecleanup
($filename);
1998 my $meta = $updater->getmeta($filename);
2000 next unless ( $meta->{revision
} );
2002 # get all the commits that this file was in
2003 # in dense format -- aka skip dead revisions
2004 my $revisions = $updater->gethistorydense($filename);
2005 my $lastseenin = $revisions->[0][2];
2007 # populate the temporary index based on the latest commit were we saw
2008 # the file -- but do it cheaply without checking out any files
2009 # TODO: if we got a revision from the client, use that instead
2010 # to look up the commithash in sqlite (still good to default to
2011 # the current head as we do now)
2012 system("git", "read-tree", $lastseenin);
2015 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2018 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
2020 # do a checkout of the file
2021 system('git', 'checkout-index', '-f', '-u', $filename);
2023 print "E error running git-checkout-index -f -u $filename : $!\n";
2027 $log->info("Annotate $filename");
2029 # Prepare a file with the commits from the linearized
2030 # history that annotate should know about. This prevents
2031 # git-jsannotate telling us about commits we are hiding
2034 my $a_hints = "$work->{workDir}/.annotate_hints";
2035 if (!open(ANNOTATEHINTS
, '>', $a_hints)) {
2036 print "E failed to open '$a_hints' for writing: $!\n";
2039 for (my $i=0; $i < @
$revisions; $i++)
2041 print ANNOTATEHINTS
$revisions->[$i][2];
2042 if ($i+1 < @
$revisions) { # have we got a parent?
2043 print ANNOTATEHINTS
' ' . $revisions->[$i+1][2];
2045 print ANNOTATEHINTS
"\n";
2048 print ANNOTATEHINTS
"\n";
2050 or (print "E failed to write $a_hints: $!\n"), return;
2052 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2053 if (!open(ANNOTATE
, "-|", @cmd)) {
2054 print "E error invoking ". join(' ',@cmd) .": $!\n";
2058 print "E Annotations for $filename\n";
2059 print "E ***************\n";
2060 while ( <ANNOTATE
> )
2062 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2064 my $commithash = $1;
2066 unless ( defined ( $metadata->{$commithash} ) )
2068 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2069 $metadata->{$commithash}{author
} = cvs_author
($metadata->{$commithash}{author
});
2070 $metadata->{$commithash}{modified
} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2072 printf("M 1.%-5d (%-8s %10s): %s\n",
2073 $metadata->{$commithash}{revision
},
2074 $metadata->{$commithash}{author
},
2075 $metadata->{$commithash}{modified
},
2079 $log->warn("Error in annotate output! LINE: $_");
2080 print "E Annotate error \n";
2087 # done; get out of the tempdir
2094 # This method takes the state->{arguments} array and produces two new arrays.
2095 # The first is $state->{args} which is everything before the '--' argument, and
2096 # the second is $state->{files} which is everything after it.
2099 $state->{args
} = [];
2100 $state->{files
} = [];
2103 return unless( defined($state->{arguments
}) and ref $state->{arguments
} eq "ARRAY" );
2107 if ( defined($type) )
2110 $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" );
2111 $opt = { v
=> 0, l
=> 0, R
=> 0 } if ( $type eq "status" );
2112 $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" );
2113 $opt = { l
=> 0, R
=> 0, k
=> 1, D
=> 1, D
=> 1, r
=> 2 } if ( $type eq "diff" );
2114 $opt = { c
=> 0, R
=> 0, l
=> 0, f
=> 0, F
=> 1, m
=> 1, r
=> 1 } if ( $type eq "ci" );
2115 $opt = { k
=> 1, m
=> 1 } if ( $type eq "add" );
2116 $opt = { f
=> 0, l
=> 0, R
=> 0 } if ( $type eq "remove" );
2117 $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" );
2120 while ( scalar ( @
{$state->{arguments
}} ) > 0 )
2122 my $arg = shift @
{$state->{arguments
}};
2124 next if ( $arg eq "--" );
2125 next unless ( $arg =~ /\S/ );
2127 # if the argument looks like a switch
2128 if ( $arg =~ /^-(\w)(.*)/ )
2130 # if it's a switch that takes an argument
2133 # If this switch has already been provided
2134 if ( $opt->{$1} > 1 and exists ( $state->{opt
}{$1} ) )
2136 $state->{opt
}{$1} = [ $state->{opt
}{$1} ];
2137 if ( length($2) > 0 )
2139 push @
{$state->{opt
}{$1}},$2;
2141 push @
{$state->{opt
}{$1}}, shift @
{$state->{arguments
}};
2144 # if there's extra data in the arg, use that as the argument for the switch
2145 if ( length($2) > 0 )
2147 $state->{opt
}{$1} = $2;
2149 $state->{opt
}{$1} = shift @
{$state->{arguments
}};
2153 $state->{opt
}{$1} = undef;
2158 push @
{$state->{args
}}, $arg;
2166 foreach my $value ( @
{$state->{arguments
}} )
2168 if ( $value eq "--" )
2173 push @
{$state->{args
}}, $value if ( $mode == 0 );
2174 push @
{$state->{files
}}, $value if ( $mode == 1 );
2179 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2182 my $updater = shift;
2184 $state->{args
} = [] if ( scalar(@
{$state->{args
}}) == 1 and $state->{args
}[0] eq "." );
2186 return if ( scalar ( @
{$state->{args
}} ) > 1 );
2188 my @gethead = @
{$updater->gethead};
2191 foreach my $file (keys %{$state->{entries
}}) {
2192 if ( exists $state->{entries
}{$file}{revision
} &&
2193 $state->{entries
}{$file}{revision
} == 0 )
2195 push @gethead, { name
=> $file, filehash
=> 'added' };
2199 if ( scalar(@
{$state->{args
}}) == 1 )
2201 my $arg = $state->{args
}[0];
2202 $arg .= $state->{prependdir
} if ( defined ( $state->{prependdir
} ) );
2204 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2206 foreach my $file ( @gethead )
2208 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
2209 next unless ( $file->{name
} =~ /^$arg\// or $file->{name
} eq $arg );
2210 push @
{$state->{args
}}, $file->{name
};
2213 shift @
{$state->{args
}} if ( scalar(@
{$state->{args
}}) > 1 );
2215 $log->info("Only one arg specified, populating file list automatically");
2217 $state->{args
} = [];
2219 foreach my $file ( @gethead )
2221 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
2222 next unless ( $file->{name
} =~ s/^$state->{prependdir}// );
2223 push @
{$state->{args
}}, $file->{name
};
2228 # This method cleans up the $state variable after a command that uses arguments has run
2231 $state->{files
} = [];
2232 $state->{args
} = [];
2233 $state->{arguments
} = [];
2234 $state->{entries
} = {};
2237 # Return working directory revision int "X" from CVS revision "1.X" out
2238 # of the the working directory "entries" state, for the given filename.
2239 # Return negative "X" to represent the file is scheduled for removal
2240 # when it is committed.
2243 my $filename = shift;
2245 return undef unless ( defined ( $state->{entries
}{$filename}{revision
} ) );
2247 return $1 if ( $state->{entries
}{$filename}{revision
} =~ /^1\.(\d+)/ );
2248 return -$1 if ( $state->{entries
}{$filename}{revision
} =~ /^-1\.(\d+)/ );
2253 # This method takes a file hash and does a CVS "file transfer". Its
2254 # exact behaviour depends on a second, optional hash table argument:
2255 # - If $options->{targetfile}, dump the contents to that file;
2256 # - If $options->{print}, use M/MT to transmit the contents one line
2258 # - Otherwise, transmit the size of the file, followed by the file
2262 my $filehash = shift;
2263 my $options = shift;
2265 if ( defined ( $filehash ) and $filehash eq "deleted" )
2267 $log->warn("filehash is 'deleted'");
2271 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2273 my $type = `git cat-file -t $filehash`;
2276 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2278 my $size = `git cat-file -s $filehash`;
2281 $log->debug("transmitfile($filehash) size=$size, type=$type");
2283 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2285 if ( defined ( $options->{targetfile
} ) )
2287 my $targetfile = $options->{targetfile
};
2288 open NEWFILE
, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2289 print NEWFILE
$_ while ( <$fh> );
2290 close NEWFILE
or die("Failed to write '$targetfile': $!");
2291 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2296 print 'MT text ', $_, "\n";
2301 print while ( <$fh> );
2303 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2305 die("Couldn't execute git-cat-file");
2309 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2310 # refers to the directory portion and the file portion of the filename
2314 my $filename = shift;
2315 my $fixforlocaldir = shift;
2317 my ( $filepart, $dirpart ) = ( $filename, "." );
2318 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2321 if ( $fixforlocaldir )
2323 $dirpart =~ s/^$state->{prependdir}//;
2326 return ( $filepart, $dirpart );
2331 my $filename = shift;
2333 return undef unless(defined($filename));
2334 if ( $filename =~ /^\// )
2336 print "E absolute filenames '$filename' not supported by server\n";
2340 $filename =~ s/^\.\///g
;
2341 $filename = $state->{prependdir
} . $filename;
2347 if( !defined($state->{CVSROOT
}) )
2349 print "error 1 CVSROOT not specified\n";
2353 if( $ENV{GIT_DIR
} ne ($state->{CVSROOT
} . '/') )
2355 print "error 1 Internally inconsistent CVSROOT\n";
2361 # Setup working directory in a work tree with the requested version
2362 # loaded in the index.
2369 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2370 defined($work->{tmpDir
}) )
2372 $log->warn("Bad work tree state management");
2373 print "error 1 Internal setup multiple work trees without cleanup\n";
2378 $work->{workDir
} = tempdir
( DIR
=> $TEMP_DIR );
2380 if( !defined($work->{index}) )
2382 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2385 chdir $work->{workDir
} or
2386 die "Unable to chdir to $work->{workDir}\n";
2388 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2390 $ENV{GIT_WORK_TREE
} = ".";
2391 $ENV{GIT_INDEX_FILE
} = $work->{index};
2396 system("git","read-tree",$ver);
2399 $log->warn("Error running git-read-tree");
2400 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2403 # else # req_annotate reads tree for each file
2406 # Ensure current directory is in some kind of working directory,
2407 # with a recent version loaded in the index.
2410 if( defined($work->{tmpDir
}) )
2412 $log->warn("Bad work tree state management [ensureWorkTree()]");
2413 print "error 1 Internal setup multiple dirs without cleanup\n";
2417 if( $work->{state} )
2424 if( !defined($work->{emptyDir
}) )
2426 $work->{emptyDir
} = tempdir
( DIR
=> $TEMP_DIR, OPEN
=> 0);
2428 chdir $work->{emptyDir
} or
2429 die "Unable to chdir to $work->{emptyDir}\n";
2431 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2433 if ($ver !~ /^[0-9a-f]{40}$/)
2435 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2436 print "error 1 cannot find the current HEAD of module";
2441 if( !defined($work->{index}) )
2443 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2446 $ENV{GIT_WORK_TREE
} = ".";
2447 $ENV{GIT_INDEX_FILE
} = $work->{index};
2450 system("git","read-tree",$ver);
2453 die "Error running git-read-tree $ver $!\n";
2457 # Cleanup working directory that is not needed any longer.
2460 if( ! $work->{state} )
2465 chdir "/" or die "Unable to chdir '/'\n";
2467 if( defined($work->{workDir
}) )
2469 rmtree
( $work->{workDir
} );
2470 undef $work->{workDir
};
2472 undef $work->{state};
2475 # Setup a temporary directory (not a working tree), typically for
2476 # merging dirty state as in req_update.
2479 $work->{tmpDir
} = tempdir
( DIR
=> $TEMP_DIR );
2480 chdir $work->{tmpDir
} or die "Unable to chdir $work->{tmpDir}\n";
2482 return $work->{tmpDir
};
2485 # Clean up a previously setupTmpDir. Restore previous work tree if
2489 if ( !defined($work->{tmpDir
}) )
2491 $log->warn("cleanup tmpdir that has not been setup");
2492 die "Cleanup tmpDir that has not been setup\n";
2494 if( defined($work->{state}) )
2496 if( $work->{state} == 1 )
2498 chdir $work->{emptyDir
} or
2499 die "Unable to chdir to $work->{emptyDir}\n";
2501 elsif( $work->{state} == 2 )
2503 chdir $work->{workDir
} or
2504 die "Unable to chdir to $work->{emptyDir}\n";
2508 $log->warn("Inconsistent work dir state");
2509 die "Inconsistent work dir state\n";
2514 chdir "/" or die "Unable to chdir '/'\n";
2518 # Given a path, this function returns a string containing the kopts
2519 # that should go into that path's Entries line. For example, a binary
2520 # file should get -kb.
2523 my ($path, $srcType, $name) = @_;
2525 if ( defined ( $cfg->{gitcvs
}{usecrlfattr
} ) and
2526 $cfg->{gitcvs
}{usecrlfattr
} =~ /\s*(1|true|yes)\s*$/i )
2528 my ($val) = check_attr
( "text", $path );
2529 if ( $val eq "unspecified" )
2531 $val = check_attr
( "crlf", $path );
2533 if ( $val eq "unset" )
2537 elsif ( check_attr
( "eol", $path ) ne "unspecified" ||
2538 $val eq "set" || $val eq "input" )
2544 $log->info("Unrecognized check_attr crlf $path : $val");
2548 if ( defined ( $cfg->{gitcvs
}{allbinary
} ) )
2550 if( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*(1|true|yes)\s*$/i) )
2554 elsif( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*guess\s*$/i) )
2556 if( is_binary
($srcType,$name) )
2558 $log->debug("... as binary");
2563 $log->debug("... as text");
2567 # Return "" to give no special treatment to any path
2573 my ($attr,$path) = @_;
2575 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2579 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2588 # This should have the same heuristics as convert.c:is_binary() and related.
2589 # Note that the bare CR test is done by callers in convert.c.
2592 my ($srcType,$name) = @_;
2593 $log->debug("is_binary($srcType,$name)");
2595 # Minimize amount of interpreted code run in the inner per-character
2596 # loop for large files, by totalling each character value and
2597 # then analyzing the totals.
2600 for($i=0;$i<256;$i++)
2605 my $fh = open_blob_or_die
($srcType,$name);
2607 while( defined($line=<$fh>) )
2609 # Any '\0' and bare CR are considered binary.
2610 if( $line =~ /\0|(\r[^\n])/ )
2616 # Count up each character in the line:
2617 my $len=length($line);
2618 for($i=0;$i<$len;$i++)
2620 $counts[ord(substr($line,$i,1))]++;
2625 # Don't count CR and LF as either printable/nonprintable
2626 $counts[ord("\n")]=0;
2627 $counts[ord("\r")]=0;
2629 # Categorize individual character count into printable and nonprintable:
2632 for($i=0;$i<256;$i++)
2640 $nonprintable+=$counts[$i];
2642 elsif( $i==127 ) # DEL
2644 $nonprintable+=$counts[$i];
2648 $printable+=$counts[$i];
2652 return ($printable >> 7) < $nonprintable;
2655 # Returns open file handle. Possible invocations:
2656 # - open_blob_or_die("file",$filename);
2657 # - open_blob_or_die("sha1",$filehash);
2658 sub open_blob_or_die
2660 my ($srcType,$name) = @_;
2662 if( $srcType eq "file" )
2664 if( !open $fh,"<",$name )
2666 $log->warn("Unable to open file $name: $!");
2667 die "Unable to open file $name: $!\n";
2670 elsif( $srcType eq "sha1" )
2672 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2674 $log->warn("Need filehash");
2675 die "Need filehash\n";
2678 my $type = `git cat-file -t $name`;
2681 unless ( defined ( $type ) and $type eq "blob" )
2683 $log->warn("Invalid type '$type' for '$name'");
2684 die ( "Invalid type '$type' (expected 'blob')" )
2687 my $size = `git cat-file -s $name`;
2690 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2692 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2694 $log->warn("Unable to open sha1 $name");
2695 die "Unable to open sha1 $name\n";
2700 $log->warn("Unknown type of blob source: $srcType");
2701 die "Unknown type of blob source: $srcType\n";
2706 # Generate a CVS author name from Git author information, by taking the local
2707 # part of the email address and replacing characters not in the Portable
2708 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2709 # Login names are Unix login names, which should be restricted to this
2713 my $author_line = shift;
2714 (my $author) = $author_line =~ /<([^@>]*)/;
2716 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2725 # This table is from src/scramble.c in the CVS source
2727 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2728 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2729 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2730 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2731 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2732 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2733 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2734 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2735 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2736 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2737 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2738 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2739 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2740 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2741 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2742 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2746 # This should never happen, the same password format (A) has been
2747 # used by CVS since the beginning of time
2749 my $fmt = substr($str, 0, 1);
2750 die "invalid password format `$fmt'" unless $fmt eq 'A';
2753 my @str = unpack "C*", substr($str, 1);
2754 my $ret = join '', map { chr $SHIFTS[$_] } @str;
2759 package GITCVS
::log;
2762 #### Copyright The Open University UK - 2006.
2764 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2765 #### Martin Langhoff <martin@laptop.org>
2778 This module provides very crude logging with a similar interface to
2787 Creates a new log object, optionally you can specify a filename here to
2788 indicate the file to log to. If no log file is specified, you can specify one
2789 later with method setfile, or indicate you no longer want logging with method
2792 Until one of these methods is called, all log calls will buffer messages ready
2799 my $filename = shift;
2803 bless $self, $class;
2805 if ( defined ( $filename ) )
2807 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2815 This methods takes a filename, and attempts to open that file as the log file.
2816 If successful, all buffered data is written out to the file, and any further
2817 logging is written directly to the file.
2823 my $filename = shift;
2825 if ( defined ( $filename ) )
2827 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2830 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2832 while ( my $line = shift @
{$self->{buffer
}} )
2834 print {$self->{fh
}} $line;
2840 This method indicates no logging is going to be used. It flushes any entries in
2841 the internal buffer, and sets a flag to ensure no further data is put there.
2850 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2852 $self->{buffer
} = [];
2857 Internal method. Returns true if the log file is open, false otherwise.
2864 return 1 if ( defined ( $self->{fh
} ) and ref $self->{fh
} eq "GLOB" );
2868 =head2 debug info warn fatal
2870 These four methods are wrappers to _log. They provide the actual interface for
2874 sub debug
{ my $self = shift; $self->_log("debug", @_); }
2875 sub info
{ my $self = shift; $self->_log("info" , @_); }
2876 sub warn { my $self = shift; $self->_log("warn" , @_); }
2877 sub fatal
{ my $self = shift; $self->_log("fatal", @_); }
2881 This is an internal method called by the logging functions. It generates a
2882 timestamp and pushes the logged line either to file, or internal buffer.
2890 return if ( $self->{nolog
} );
2892 my @time = localtime;
2893 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2903 if ( $self->_logopen )
2905 print {$self->{fh
}} $timestring . " - " . join(" ",@_) . "\n";
2907 push @
{$self->{buffer
}}, $timestring . " - " . join(" ",@_) . "\n";
2913 This method simply closes the file handle if one is open
2920 if ( $self->_logopen )
2926 package GITCVS
::updater
;
2929 #### Copyright The Open University UK - 2006.
2931 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2932 #### Martin Langhoff <martin@laptop.org>
2954 die "Need to specify a git repository" unless ( defined($config) and -d
$config );
2955 die "Need to specify a module" unless ( defined($module) );
2957 $class = ref($class) || $class;
2961 bless $self, $class;
2963 $self->{valid_tables
} = {'revision' => 1,
2964 'revision_ix1' => 1,
2965 'revision_ix2' => 1,
2971 $self->{module
} = $module;
2972 $self->{git_path
} = $config . "/";
2974 $self->{log} = $log;
2976 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d
$self->{git_path
} );
2978 $self->{dbdriver
} = $cfg->{gitcvs
}{$state->{method
}}{dbdriver
} ||
2979 $cfg->{gitcvs
}{dbdriver
} || "SQLite";
2980 $self->{dbname
} = $cfg->{gitcvs
}{$state->{method
}}{dbname
} ||
2981 $cfg->{gitcvs
}{dbname
} || "%Ggitcvs.%m.sqlite";
2982 $self->{dbuser
} = $cfg->{gitcvs
}{$state->{method
}}{dbuser
} ||
2983 $cfg->{gitcvs
}{dbuser
} || "";
2984 $self->{dbpass
} = $cfg->{gitcvs
}{$state->{method
}}{dbpass
} ||
2985 $cfg->{gitcvs
}{dbpass
} || "";
2986 $self->{dbtablenameprefix
} = $cfg->{gitcvs
}{$state->{method
}}{dbtablenameprefix
} ||
2987 $cfg->{gitcvs
}{dbtablenameprefix
} || "";
2988 my %mapping = ( m
=> $module,
2989 a
=> $state->{method
},
2990 u
=> getlogin || getpwuid($<) || $<,
2991 G
=> $self->{git_path
},
2992 g
=> mangle_dirname
($self->{git_path
}),
2994 $self->{dbname
} =~ s/%([mauGg])/$mapping{$1}/eg;
2995 $self->{dbuser
} =~ s/%([mauGg])/$mapping{$1}/eg;
2996 $self->{dbtablenameprefix
} =~ s/%([mauGg])/$mapping{$1}/eg;
2997 $self->{dbtablenameprefix
} = mangle_tablename
($self->{dbtablenameprefix
});
2999 die "Invalid char ':' in dbdriver" if $self->{dbdriver
} =~ /:/;
3000 die "Invalid char ';' in dbname" if $self->{dbname
} =~ /;/;
3001 $self->{dbh
} = DBI
->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
3004 die "Error connecting to database\n" unless defined $self->{dbh
};
3006 $self->{tables
} = {};
3007 foreach my $table ( keys %{$self->{dbh
}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3009 $self->{tables
}{$table} = 1;
3012 # Construct the revision table if required
3013 # The revision table stores an entry for each file, each time that file
3015 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3016 # This is not sufficient to support "-r {commithash}" for any
3017 # files except files that were modified by that commit (also,
3018 # some places in the code ignore/effectively strip out -r in
3019 # some cases, before it gets passed to getmeta()).
3020 # The "filehash" field typically has a git blob hash, but can also
3021 # be set to "dead" to indicate that the given version of the file
3022 # should not exist in the sandbox.
3023 unless ( $self->{tables
}{$self->tablename("revision")} )
3025 my $tablename = $self->tablename("revision");
3026 my $ix1name = $self->tablename("revision_ix1");
3027 my $ix2name = $self->tablename("revision_ix2");
3029 CREATE TABLE $tablename (
3031 revision INTEGER NOT NULL,
3032 filehash TEXT NOT NULL,
3033 commithash TEXT NOT NULL,
3034 author TEXT NOT NULL,
3035 modified TEXT NOT NULL,
3040 CREATE INDEX $ix1name
3041 ON $tablename (name,revision)
3044 CREATE INDEX $ix2name
3045 ON $tablename (name,commithash)
3049 # Construct the head table if required
3050 # The head table (along with the "last_commit" entry in the property
3051 # table) is the persisted working state of the "sub update" subroutine.
3052 # All of it's data is read entirely first, and completely recreated
3053 # last, every time "sub update" runs.
3054 # This is also used by "sub getmeta" when it is asked for the latest
3055 # version of a file (as opposed to some specific version).
3056 # Another way of thinking about it is as a single slice out of
3057 # "revisions", giving just the most recent revision information for
3059 unless ( $self->{tables
}{$self->tablename("head")} )
3061 my $tablename = $self->tablename("head");
3062 my $ix1name = $self->tablename("head_ix1");
3064 CREATE TABLE $tablename (
3066 revision INTEGER NOT NULL,
3067 filehash TEXT NOT NULL,
3068 commithash TEXT NOT NULL,
3069 author TEXT NOT NULL,
3070 modified TEXT NOT NULL,
3075 CREATE INDEX $ix1name
3076 ON $tablename (name)
3080 # Construct the properties table if required
3081 # - "last_commit" - Used by "sub update".
3082 unless ( $self->{tables
}{$self->tablename("properties")} )
3084 my $tablename = $self->tablename("properties");
3086 CREATE TABLE $tablename (
3087 key TEXT NOT NULL PRIMARY KEY,
3093 # Construct the commitmsgs table if required
3094 # The commitmsgs table is only used for merge commits, since
3095 # "sub update" will only keep one branch of parents. Shortlogs
3096 # for ignored commits (i.e. not on the chosen branch) will be used
3097 # to construct a replacement "collapsed" merge commit message,
3098 # which will be stored in this table. See also "sub commitmessage".
3099 unless ( $self->{tables
}{$self->tablename("commitmsgs")} )
3101 my $tablename = $self->tablename("commitmsgs");
3103 CREATE TABLE $tablename (
3104 key TEXT NOT NULL PRIMARY KEY,
3121 if (exists $self->{valid_tables
}{$name}) {
3122 return $self->{dbtablenameprefix
} . $name;
3130 Bring the database up to date with the latest changes from
3133 Internal working state is read out of the "head" table and the
3134 "last_commit" property, then it updates "revisions" based on that, and
3135 finally it writes the new internal state back to the "head" table
3136 so it can be used as a starting point the next time update is called.
3143 # first lets get the commit list
3144 $ENV{GIT_DIR
} = $self->{git_path
};
3146 my $commitsha1 = `git rev-parse $self->{module}`;
3149 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3150 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3152 die("Invalid module '$self->{module}'");
3157 my $lastcommit = $self->_get_prop("last_commit");
3159 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3163 # Start exclusive lock here...
3164 $self->{dbh
}->begin_work() or die "Cannot lock database for BEGIN";
3166 # TODO: log processing is memory bound
3167 # if we can parse into a 2nd file that is in reverse order
3168 # we can probably do something really efficient
3169 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3171 if (defined $lastcommit) {
3172 push @git_log_params, "$lastcommit..$self->{module}";
3174 push @git_log_params, $self->{module
};
3176 # git-rev-list is the backend / plumbing version of git-log
3177 open(GITLOG
, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3186 if (m/^commit\s+(.*)$/) {
3187 # on ^commit lines put the just seen commit in the stack
3188 # and prime things for the next one
3191 unshift @commits, \
%copy;
3194 my @parents = split(m/\s+/, $1);
3195 $commit{hash
} = shift @parents;
3196 $commit{parents
} = \
@parents;
3197 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message
})) {
3198 # on rfc822-like lines seen before we see any message,
3199 # lowercase the entry and put it in the hash as key-value
3200 $commit{lc($1)} = $2;
3202 # message lines - skip initial empty line
3203 # and trim whitespace
3204 if (!exists($commit{message
}) && m/^\s*$/) {
3205 # define it to mark the end of headers
3206 $commit{message
} = '';
3209 s/^\s+//; s/\s+$//; # trim ws
3210 $commit{message
} .= $_ . "\n";
3215 unshift @commits, \
%commit if ( keys %commit );
3217 # Now all the commits are in the @commits bucket
3218 # ordered by time DESC. for each commit that needs processing,
3219 # determine whether it's following the last head we've seen or if
3220 # it's on its own branch, grab a file list, and add whatever's changed
3221 # NOTE: $lastcommit refers to the last commit from previous run
3222 # $lastpicked is the last commit we picked in this run
3225 if (defined $lastcommit) {
3226 $lastpicked = $lastcommit;
3229 my $committotal = scalar(@commits);
3230 my $commitcount = 0;
3232 # Load the head table into $head (for cached lookups during the update process)
3233 foreach my $file ( @
{$self->gethead()} )
3235 $head->{$file->{name
}} = $file;
3238 foreach my $commit ( @commits )
3240 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3241 if (defined $lastpicked)
3243 if (!in_array
($lastpicked, @
{$commit->{parents
}}))
3245 # skip, we'll see this delta
3246 # as part of a merge later
3247 # warn "skipping off-track $commit->{hash}\n";
3249 } elsif (@
{$commit->{parents
}} > 1) {
3250 # it is a merge commit, for each parent that is
3251 # not $lastpicked (not given a CVS revision number),
3252 # see if we can get a log
3253 # from the merge-base to that parent to put it
3254 # in the message as a merge summary.
3255 my @parents = @
{$commit->{parents
}};
3256 foreach my $parent (@parents) {
3257 if ($parent eq $lastpicked) {
3260 # git-merge-base can potentially (but rarely) throw
3261 # several candidate merge bases. let's assume
3262 # that the first one is the best one.
3264 safe_pipe_capture
('git', 'merge-base',
3265 $lastpicked, $parent);
3267 # The two branches may not be related at all,
3268 # in which case merge base simply fails to find
3269 # any, but that's Ok.
3275 # print "want to log between $base $parent \n";
3276 open(GITLOG
, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3277 or die "Cannot call git-log: $!";
3281 if (!defined $mergedhash) {
3282 if (m/^commit\s+(.+)$/) {
3288 # grab the first line that looks non-rfc822
3289 # aka has content after leading space
3290 if (m/^\s+(\S.*)$/) {
3292 $title = substr($title,0,100); # truncate
3293 unshift @merged, "$mergedhash $title";
3300 $commit->{mergemsg
} = $commit->{message
};
3301 $commit->{mergemsg
} .= "\nSummary of merged commits:\n\n";
3302 foreach my $summary (@merged) {
3303 $commit->{mergemsg
} .= "\t$summary\n";
3305 $commit->{mergemsg
} .= "\n\n";
3306 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3313 # convert the date to CVS-happy format
3314 $commit->{date
} = "$2 $1 $4 $3 $5" if ( $commit->{date
} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3316 if ( defined ( $lastpicked ) )
3318 my $filepipe = open(FILELIST
, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash
}) or die("Cannot call git-diff-tree : $!");
3320 while ( <FILELIST
> )
3323 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3325 die("Couldn't process git-diff-tree line : $_");
3327 my ($mode, $hash, $change) = ($1, $2, $3);
3328 my $name = <FILELIST
>;
3331 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3334 $git_perms .= "r" if ( $mode & 4 );
3335 $git_perms .= "w" if ( $mode & 2 );
3336 $git_perms .= "x" if ( $mode & 1 );
3337 $git_perms = "rw" if ( $git_perms eq "" );
3339 if ( $change eq "D" )
3341 #$log->debug("DELETE $name");
3344 revision
=> $head->{$name}{revision
} + 1,
3345 filehash
=> "deleted",
3346 commithash
=> $commit->{hash
},
3347 modified
=> $commit->{date
},
3348 author
=> $commit->{author
},
3351 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3353 elsif ( $change eq "M" || $change eq "T" )
3355 #$log->debug("MODIFIED $name");
3358 revision
=> $head->{$name}{revision
} + 1,
3360 commithash
=> $commit->{hash
},
3361 modified
=> $commit->{date
},
3362 author
=> $commit->{author
},
3365 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3367 elsif ( $change eq "A" )
3369 #$log->debug("ADDED $name");
3372 revision
=> $head->{$name}{revision
} ?
$head->{$name}{revision
}+1 : 1,
3374 commithash
=> $commit->{hash
},
3375 modified
=> $commit->{date
},
3376 author
=> $commit->{author
},
3379 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3383 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3389 # this is used to detect files removed from the repo
3390 my $seen_files = {};
3392 my $filepipe = open(FILELIST
, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash
}) or die("Cannot call git-ls-tree : $!");
3394 while ( <FILELIST
> )
3397 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3399 die("Couldn't process git-ls-tree line : $_");
3402 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3404 $seen_files->{$git_filename} = 1;
3406 my ( $oldhash, $oldrevision, $oldmode ) = (
3407 $head->{$git_filename}{filehash
},
3408 $head->{$git_filename}{revision
},
3409 $head->{$git_filename}{mode
}
3412 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3415 $git_perms .= "r" if ( $1 & 4 );
3416 $git_perms .= "w" if ( $1 & 2 );
3417 $git_perms .= "x" if ( $1 & 1 );
3422 # unless the file exists with the same hash, we need to update it ...
3423 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3425 my $newrevision = ( $oldrevision or 0 ) + 1;
3427 $head->{$git_filename} = {
3428 name
=> $git_filename,
3429 revision
=> $newrevision,
3430 filehash
=> $git_hash,
3431 commithash
=> $commit->{hash
},
3432 modified
=> $commit->{date
},
3433 author
=> $commit->{author
},
3438 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
3443 # Detect deleted files
3444 foreach my $file ( keys %$head )
3446 unless ( exists $seen_files->{$file} or $head->{$file}{filehash
} eq "deleted" )
3448 $head->{$file}{revision
}++;
3449 $head->{$file}{filehash
} = "deleted";
3450 $head->{$file}{commithash
} = $commit->{hash
};
3451 $head->{$file}{modified
} = $commit->{date
};
3452 $head->{$file}{author
} = $commit->{author
};
3454 $self->insert_rev($file, $head->{$file}{revision
}, $head->{$file}{filehash
}, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $head->{$file}{mode
});
3457 # END : "Detect deleted files"
3461 if (exists $commit->{mergemsg
})
3463 $self->insert_mergelog($commit->{hash
}, $commit->{mergemsg
});
3466 $lastpicked = $commit->{hash
};
3468 $self->_set_prop("last_commit", $commit->{hash
});
3471 $self->delete_head();
3472 foreach my $file ( keys %$head )
3476 $head->{$file}{revision
},
3477 $head->{$file}{filehash
},
3478 $head->{$file}{commithash
},
3479 $head->{$file}{modified
},
3480 $head->{$file}{author
},
3481 $head->{$file}{mode
},
3484 # invalidate the gethead cache
3485 $self->{gethead_cache
} = undef;
3488 # Ending exclusive lock here
3489 $self->{dbh
}->commit() or die "Failed to commit changes to SQLite";
3496 my $revision = shift;
3497 my $filehash = shift;
3498 my $commithash = shift;
3499 my $modified = shift;
3502 my $tablename = $self->tablename("revision");
3504 my $insert_rev = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3505 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3513 my $tablename = $self->tablename("commitmsgs");
3515 my $insert_mergelog = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3516 $insert_mergelog->execute($key, $value);
3522 my $tablename = $self->tablename("head");
3524 my $delete_head = $self->{dbh
}->prepare_cached("DELETE FROM $tablename",{},1);
3525 $delete_head->execute();
3532 my $revision = shift;
3533 my $filehash = shift;
3534 my $commithash = shift;
3535 my $modified = shift;
3538 my $tablename = $self->tablename("head");
3540 my $insert_head = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3541 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3548 my $tablename = $self->tablename("properties");
3550 my $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3551 $db_query->execute($key);
3552 my ( $value ) = $db_query->fetchrow_array;
3562 my $tablename = $self->tablename("properties");
3564 my $db_query = $self->{dbh
}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3565 $db_query->execute($value, $key);
3567 unless ( $db_query->rows )
3569 $db_query = $self->{dbh
}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3570 $db_query->execute($key, $value);
3583 my $tablename = $self->tablename("head");
3585 return $self->{gethead_cache
} if ( defined ( $self->{gethead_cache
} ) );
3587 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3588 $db_query->execute();
3591 while ( my $file = $db_query->fetchrow_hashref )
3596 $self->{gethead_cache
} = $tree;
3603 See also gethistorydense().
3610 my $filename = shift;
3611 my $tablename = $self->tablename("revision");
3613 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3614 $db_query->execute($filename);
3617 while ( my $file = $db_query->fetchrow_hashref )
3627 This function takes a filename (with path) argument and returns a hashref of
3628 metadata for that file.
3635 my $filename = shift;
3636 my $revision = shift;
3637 my $tablename_rev = $self->tablename("revision");
3638 my $tablename_head = $self->tablename("head");
3641 if ( defined($revision) and $revision =~ /^\d+$/ )
3643 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3644 $db_query->execute($filename, $revision);
3646 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3648 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3649 $db_query->execute($filename, $revision);
3651 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3652 $db_query->execute($filename);
3655 return $db_query->fetchrow_hashref;
3658 =head2 commitmessage
3660 this function takes a commithash and returns the commit message for that commit
3666 my $commithash = shift;
3667 my $tablename = $self->tablename("commitmsgs");
3669 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3672 $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3673 $db_query->execute($commithash);
3675 my ( $message ) = $db_query->fetchrow_array;
3677 if ( defined ( $message ) )
3679 $message .= " " if ( $message =~ /\n$/ );
3683 my @lines = safe_pipe_capture
("git", "cat-file", "commit", $commithash);
3684 shift @lines while ( $lines[0] =~ /\S/ );
3685 $message = join("",@lines);
3686 $message .= " " if ( $message =~ /\n$/ );
3690 =head2 gethistorydense
3692 This function takes a filename (with path) argument and returns an arrayofarrays
3693 containing revision,filehash,commithash ordered by revision descending.
3695 This version of gethistory skips deleted entries -- so it is useful for annotate.
3696 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3697 and other git tools that depend on it.
3705 my $filename = shift;
3706 my $tablename = $self->tablename("revision");
3709 $db_query = $self->{dbh
}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3710 $db_query->execute($filename);
3712 return $db_query->fetchall_arrayref;
3717 from Array::PAT - mimics the in_array() function
3718 found in PHP. Yuck but works for small arrays.
3723 my ($check, @array) = @_;
3725 foreach my $test (@array){
3726 if($check eq $test){
3733 =head2 safe_pipe_capture
3735 an alternative to `command` that allows input to be passed as an array
3736 to work around shell problems with weird characters in arguments
3739 sub safe_pipe_capture
{
3743 if (my $pid = open my $child, '-|') {
3744 @output = (<$child>);
3745 close $child or die join(' ',@_).": $! $?";
3747 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3749 return wantarray ?
@output : join('',@output);
3752 =head2 mangle_dirname
3754 create a string from a directory name that is suitable to use as
3755 part of a filename, mainly by converting all chars except \w.- to _
3758 sub mangle_dirname
{
3759 my $dirname = shift;
3760 return unless defined $dirname;
3762 $dirname =~ s/[^\w.-]/_/g;
3767 =head2 mangle_tablename
3769 create a string from a that is suitable to use as part of an SQL table
3770 name, mainly by converting all chars except \w to _
3773 sub mangle_tablename
{
3774 my $tablename = shift;
3775 return unless defined $tablename;
3777 $tablename =~ s/[^\w_]/_/g;