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@catalyst.net.nz>
14 #### Released under the GNU Public License, version 2.
23 use File
::Temp qw
/tempdir tempfile/;
26 my $log = GITCVS
::log->new();
44 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
47 #### Definition and mappings of functions ####
51 'Valid-responses' => \
&req_Validresponses
,
52 'valid-requests' => \
&req_validrequests
,
53 'Directory' => \
&req_Directory
,
54 'Entry' => \
&req_Entry
,
55 'Modified' => \
&req_Modified
,
56 'Unchanged' => \
&req_Unchanged
,
57 'Questionable' => \
&req_Questionable
,
58 'Argument' => \
&req_Argument
,
59 'Argumentx' => \
&req_Argument
,
60 'expand-modules' => \
&req_expandmodules
,
62 'remove' => \
&req_remove
,
64 'update' => \
&req_update
,
69 'tag' => \
&req_CATCHALL
,
70 'status' => \
&req_status
,
71 'admin' => \
&req_CATCHALL
,
72 'history' => \
&req_CATCHALL
,
73 'watchers' => \
&req_CATCHALL
,
74 'editors' => \
&req_CATCHALL
,
75 'annotate' => \
&req_annotate
,
76 'Global_option' => \
&req_Globaloption
,
77 #'annotate' => \&req_CATCHALL,
80 ##############################################
83 # $state holds all the bits of information the clients sends us that could
84 # potentially be useful when it comes to actually _doing_ something.
85 my $state = { prependdir
=> '' };
86 $log->info("--------------- STARTING -----------------");
88 my $TEMP_DIR = tempdir
( CLEANUP
=> 1 );
89 $log->debug("Temporary directory is '$TEMP_DIR'");
91 # if we are called with a pserver argument,
92 # deal with the authentication cat before entering the
94 $state->{method
} = 'ext';
95 if (@ARGV && $ARGV[0] eq 'pserver') {
96 $state->{method
} = 'pserver';
97 my $line = <STDIN
>; chomp $line;
98 unless( $line eq 'BEGIN AUTH REQUEST') {
99 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
101 $line = <STDIN
>; chomp $line;
102 req_Root
('root', $line) # reuse Root
103 or die "E Invalid root $line \n";
104 $line = <STDIN
>; chomp $line;
105 unless ($line eq 'anonymous') {
106 print "E Only anonymous user allowed via pserver\n";
107 print "I HATE YOU\n";
109 $line = <STDIN
>; chomp $line; # validate the password?
110 $line = <STDIN
>; chomp $line;
111 unless ($line eq 'END AUTH REQUEST') {
112 die "E Do not understand $line -- expecting END AUTH REQUEST\n";
114 print "I LOVE YOU\n";
115 # and now back to our regular programme...
118 # Keep going until the client closes the connection
123 # Check to see if we've seen this method, and call appropriate function.
124 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
126 # use the $methods hash to call the appropriate sub for this command
127 #$log->info("Method : $1");
128 &{$methods->{$1}}($1,$2);
130 # log fatal because we don't understand this function. If this happens
131 # we're fairly screwed because we don't know if the client is expecting
132 # a response. If it is, the client will hang, we'll hang, and the whole
133 # thing will be custard.
134 $log->fatal("Don't understand command $_\n");
135 die("Unknown command $_");
139 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
140 $log->info("--------------- FINISH -----------------");
142 # Magic catchall method.
143 # This is the method that will handle all commands we haven't yet
144 # implemented. It simply sends a warning to the log file indicating a
145 # command that hasn't been implemented has been invoked.
148 my ( $cmd, $data ) = @_;
149 $log->warn("Unhandled command : req_$cmd : $data");
154 # Response expected: no. Tell the server which CVSROOT to use. Note that
155 # pathname is a local directory and not a fully qualified CVSROOT variable.
156 # pathname must already exist; if creating a new root, use the init
157 # request, not Root. pathname does not include the hostname of the server,
158 # how to access the server, etc.; by the time the CVS protocol is in use,
159 # connection, authentication, etc., are already taken care of. The Root
160 # request must be sent only once, and it must be sent before any requests
161 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
164 my ( $cmd, $data ) = @_;
165 $log->debug("req_Root : $data");
167 $state->{CVSROOT
} = $data;
169 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
170 unless (-d
$ENV{GIT_DIR
} && -e
$ENV{GIT_DIR
}.'HEAD') {
171 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
173 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
177 my @gitvars = `git-config -l`;
179 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
181 print "error 1 - problem executing git-config\n";
184 foreach my $line ( @gitvars )
186 next unless ( $line =~ /^(.*?)\.(.*?)(?:\.(.*?))?=(.*)$/ );
190 $cfg->{$1}{$2}{$3} = $4;
194 unless ( ($cfg->{gitcvs
}{$state->{method
}}{enabled
}
195 and $cfg->{gitcvs
}{$state->{method
}}{enabled
} =~ /^\s*(1|true|yes)\s*$/i)
196 or ($cfg->{gitcvs
}{enabled
}
197 and $cfg->{gitcvs
}{enabled
} =~ /^\s*(1|true|yes)\s*$/i) )
199 print "E GITCVS emulation needs to be enabled on this repo\n";
200 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
202 print "error 1 GITCVS emulation disabled\n";
206 my $logfile = $cfg->{gitcvs
}{$state->{method
}}{logfile
} || $cfg->{gitcvs
}{logfile
};
209 $log->setfile($logfile);
217 # Global_option option \n
218 # Response expected: no. Transmit one of the global options `-q', `-Q',
219 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
220 # variations (such as combining of options) are allowed. For graceful
221 # handling of valid-requests, it is probably better to make new global
222 # options separate requests, rather than trying to add them to this
226 my ( $cmd, $data ) = @_;
227 $log->debug("req_Globaloption : $data");
228 $state->{globaloptions
}{$data} = 1;
231 # Valid-responses request-list \n
232 # Response expected: no. Tell the server what responses the client will
233 # accept. request-list is a space separated list of tokens.
234 sub req_Validresponses
236 my ( $cmd, $data ) = @_;
237 $log->debug("req_Validresponses : $data");
239 # TODO : re-enable this, currently it's not particularly useful
240 #$state->{validresponses} = [ split /\s+/, $data ];
244 # Response expected: yes. Ask the server to send back a Valid-requests
246 sub req_validrequests
248 my ( $cmd, $data ) = @_;
250 $log->debug("req_validrequests");
252 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
253 $log->debug("SEND : ok");
255 print "Valid-requests " . join(" ",keys %$methods) . "\n";
259 # Directory local-directory \n
260 # Additional data: repository \n. Response expected: no. Tell the server
261 # what directory to use. The repository should be a directory name from a
262 # previous server response. Note that this both gives a default for Entry
263 # and Modified and also for ci and the other commands; normal usage is to
264 # send Directory for each directory in which there will be an Entry or
265 # Modified, and then a final Directory for the original directory, then the
266 # command. The local-directory is relative to the top level at which the
267 # command is occurring (i.e. the last Directory which is sent before the
268 # command); to indicate that top level, `.' should be sent for
272 my ( $cmd, $data ) = @_;
274 my $repository = <STDIN
>;
278 $state->{localdir
} = $data;
279 $state->{repository
} = $repository;
280 $state->{path
} = $repository;
281 $state->{path
} =~ s/^$state->{CVSROOT}\///;
282 $state->{module
} = $1 if ($state->{path
} =~ s/^(.*?)(\/|$)//);
283 $state->{path
} .= "/" if ( $state->{path
} =~ /\S
/ );
285 $state->{directory
} = $state->{localdir
};
286 $state->{directory
} = "" if ( $state->{directory
} eq "." );
287 $state->{directory
} .= "/" if ( $state->{directory
} =~ /\S
/ );
289 if ( (not defined($state->{prependdir
}) or $state->{prependdir
} eq '') and $state->{localdir
} eq "." and $state->{path
} =~ /\S/ )
291 $log->info("Setting prepend to '$state->{path}'");
292 $state->{prependdir
} = $state->{path
};
293 foreach my $entry ( keys %{$state->{entries
}} )
295 $state->{entries
}{$state->{prependdir
} . $entry} = $state->{entries
}{$entry};
296 delete $state->{entries
}{$entry};
300 if ( defined ( $state->{prependdir
} ) )
302 $log->debug("Prepending '$state->{prependdir}' to state|directory");
303 $state->{directory
} = $state->{prependdir
} . $state->{directory
}
305 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
308 # Entry entry-line \n
309 # Response expected: no. Tell the server what version of a file is on the
310 # local machine. The name in entry-line is a name relative to the directory
311 # most recently specified with Directory. If the user is operating on only
312 # some files in a directory, Entry requests for only those files need be
313 # included. If an Entry request is sent without Modified, Is-modified, or
314 # Unchanged, it means the file is lost (does not exist in the working
315 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
316 # are sent for the same file, Entry must be sent first. For a given file,
317 # one can send Modified, Is-modified, or Unchanged, but not more than one
321 my ( $cmd, $data ) = @_;
323 #$log->debug("req_Entry : $data");
325 my @data = split(/\//, $data);
327 $state->{entries
}{$state->{directory
}.$data[1]} = {
328 revision
=> $data[2],
329 conflict
=> $data[3],
331 tag_or_date
=> $data[5],
334 $log->info("Received entry line '$data' => '" . $state->{directory
} . $data[1] . "'");
337 # Questionable filename \n
338 # Response expected: no. Additional data: no. Tell the server to check
339 # whether filename should be ignored, and if not, next time the server
340 # sends responses, send (in a M response) `?' followed by the directory and
341 # filename. filename must not contain `/'; it needs to be a file in the
342 # directory named by the most recent Directory request.
345 my ( $cmd, $data ) = @_;
347 $log->debug("req_Questionable : $data");
348 $state->{entries
}{$state->{directory
}.$data}{questionable
} = 1;
352 # Response expected: yes. Add a file or directory. This uses any previous
353 # Argument, Directory, Entry, or Modified requests, if they have been sent.
354 # The last Directory sent specifies the working directory at the time of
355 # the operation. To add a directory, send the directory to be added using
356 # Directory and Argument requests.
359 my ( $cmd, $data ) = @_;
363 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
366 argsfromdir
($updater);
370 foreach my $filename ( @
{$state->{args
}} )
372 $filename = filecleanup
($filename);
374 my $meta = $updater->getmeta($filename);
375 my $wrev = revparse
($filename);
377 if ($wrev && $meta && ($wrev < 0))
379 # previously removed file, add back
380 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
382 print "MT +updated\n";
383 print "MT text U \n";
384 print "MT fname $filename\n";
385 print "MT newline\n";
386 print "MT -updated\n";
388 unless ( $state->{globaloptions
}{-n
} )
390 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
392 print "Created $dirpart\n";
393 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
395 # this is an "entries" line
396 my $kopts = kopts_from_path
($filepart);
397 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
398 print "/$filepart/1.$meta->{revision}//$kopts/\n";
400 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
401 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
403 transmitfile
($meta->{filehash
});
409 unless ( defined ( $state->{entries
}{$filename}{modified_filename
} ) )
411 print "E cvs add: nothing known about `$filename'\n";
414 # TODO : check we're not squashing an already existing file
415 if ( defined ( $state->{entries
}{$filename}{revision
} ) )
417 print "E cvs add: `$filename' has already been entered\n";
421 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
423 print "E cvs add: scheduling file `$filename' for addition\n";
425 print "Checked-in $dirpart\n";
427 my $kopts = kopts_from_path
($filepart);
428 print "/$filepart/0//$kopts/\n";
433 if ( $addcount == 1 )
435 print "E cvs add: use `cvs commit' to add this file permanently\n";
437 elsif ( $addcount > 1 )
439 print "E cvs add: use `cvs commit' to add these files permanently\n";
446 # Response expected: yes. Remove a file. This uses any previous Argument,
447 # Directory, Entry, or Modified requests, if they have been sent. The last
448 # Directory sent specifies the working directory at the time of the
449 # operation. Note that this request does not actually do anything to the
450 # repository; the only effect of a successful remove request is to supply
451 # the client with a new entries line containing `-' to indicate a removed
452 # file. In fact, the client probably could perform this operation without
453 # contacting the server, although using remove may cause the server to
454 # perform a few more checks. The client sends a subsequent ci request to
455 # actually record the removal in the repository.
458 my ( $cmd, $data ) = @_;
462 # Grab a handle to the SQLite db and do any necessary updates
463 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
466 #$log->debug("add state : " . Dumper($state));
470 foreach my $filename ( @
{$state->{args
}} )
472 $filename = filecleanup
($filename);
474 if ( defined ( $state->{entries
}{$filename}{unchanged
} ) or defined ( $state->{entries
}{$filename}{modified_filename
} ) )
476 print "E cvs remove: file `$filename' still in working directory\n";
480 my $meta = $updater->getmeta($filename);
481 my $wrev = revparse
($filename);
483 unless ( defined ( $wrev ) )
485 print "E cvs remove: nothing known about `$filename'\n";
489 if ( defined($wrev) and $wrev < 0 )
491 print "E cvs remove: file `$filename' already scheduled for removal\n";
495 unless ( $wrev == $meta->{revision
} )
497 # TODO : not sure if the format of this message is quite correct.
498 print "E cvs remove: Up to date check failed for `$filename'\n";
503 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
505 print "E cvs remove: scheduling `$filename' for removal\n";
507 print "Checked-in $dirpart\n";
509 my $kopts = kopts_from_path
($filepart);
510 print "/$filepart/-1.$wrev//$kopts/\n";
517 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
519 elsif ( $rmcount > 1 )
521 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
527 # Modified filename \n
528 # Response expected: no. Additional data: mode, \n, file transmission. Send
529 # the server a copy of one locally modified file. filename is a file within
530 # the most recent directory sent with Directory; it must not contain `/'.
531 # If the user is operating on only some files in a directory, only those
532 # files need to be included. This can also be sent without Entry, if there
533 # is no entry for the file.
536 my ( $cmd, $data ) = @_;
543 # Grab config information
544 my $blocksize = 8192;
545 my $bytesleft = $size;
548 # Get a filehandle/name to write it to
549 my ( $fh, $filename ) = tempfile
( DIR
=> $TEMP_DIR );
551 # Loop over file data writing out to temporary file.
554 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
555 read STDIN
, $tmp, $blocksize;
557 $bytesleft -= $blocksize;
562 # Ensure we have something sensible for the file mode
563 if ( $mode =~ /u=(\w+)/ )
570 # Save the file data in $state
571 $state->{entries
}{$state->{directory
}.$data}{modified_filename
} = $filename;
572 $state->{entries
}{$state->{directory
}.$data}{modified_mode
} = $mode;
573 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} = `git-hash-object $filename`;
574 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} =~ s/\s.*$//s;
576 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
579 # Unchanged filename \n
580 # Response expected: no. Tell the server that filename has not been
581 # modified in the checked out directory. The filename is a file within the
582 # most recent directory sent with Directory; it must not contain `/'.
585 my ( $cmd, $data ) = @_;
587 $state->{entries
}{$state->{directory
}.$data}{unchanged
} = 1;
589 #$log->debug("req_Unchanged : $data");
593 # Response expected: no. Save argument for use in a subsequent command.
594 # Arguments accumulate until an argument-using command is given, at which
595 # point they are forgotten.
597 # Response expected: no. Append \n followed by text to the current argument
601 my ( $cmd, $data ) = @_;
603 # Argumentx means: append to last Argument (with a newline in front)
605 $log->debug("$cmd : $data");
607 if ( $cmd eq 'Argumentx') {
608 ${$state->{arguments
}}[$#{$state->{arguments}}] .= "\n" . $data;
610 push @
{$state->{arguments
}}, $data;
615 # Response expected: yes. Expand the modules which are specified in the
616 # arguments. Returns the data in Module-expansion responses. Note that the
617 # server can assume that this is checkout or export, not rtag or rdiff; the
618 # latter do not access the working directory and thus have no need to
619 # expand modules on the client side. Expand may not be the best word for
620 # what this request does. It does not necessarily tell you all the files
621 # contained in a module, for example. Basically it is a way of telling you
622 # which working directories the server needs to know about in order to
623 # handle a checkout of the specified modules. For example, suppose that the
624 # server has a module defined by
625 # aliasmodule -a 1dir
626 # That is, one can check out aliasmodule and it will take 1dir in the
627 # repository and check it out to 1dir in the working directory. Now suppose
628 # the client already has this module checked out and is planning on using
629 # the co request to update it. Without using expand-modules, the client
630 # would have two bad choices: it could either send information about all
631 # working directories under the current directory, which could be
632 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
633 # stands for 1dir, and neglect to send information for 1dir, which would
634 # lead to incorrect operation. With expand-modules, the client would first
635 # ask for the module to be expanded:
636 sub req_expandmodules
638 my ( $cmd, $data ) = @_;
642 $log->debug("req_expandmodules : " . ( defined($data) ?
$data : "[NULL]" ) );
644 unless ( ref $state->{arguments
} eq "ARRAY" )
650 foreach my $module ( @
{$state->{arguments
}} )
652 $log->debug("SEND : Module-expansion $module");
653 print "Module-expansion $module\n";
661 # Response expected: yes. Get files from the repository. This uses any
662 # previous Argument, Directory, Entry, or Modified requests, if they have
663 # been sent. Arguments to this command are module names; the client cannot
664 # know what directories they correspond to except by (1) just sending the
665 # co request, and then seeing what directory names the server sends back in
666 # its responses, and (2) the expand-modules request.
669 my ( $cmd, $data ) = @_;
673 my $module = $state->{args
}[0];
674 my $checkout_path = $module;
676 # use the user specified directory if we're given it
677 $checkout_path = $state->{opt
}{d
} if ( exists ( $state->{opt
}{d
} ) );
679 $log->debug("req_co : " . ( defined($data) ?
$data : "[NULL]" ) );
681 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
683 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
685 # Grab a handle to the SQLite db and do any necessary updates
686 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $module, $log);
689 $checkout_path =~ s
|/$||; # get rid of trailing slashes
691 # Eclipse seems to need the Clear-sticky command
692 # to prepare the 'Entries' file for the new directory.
693 print "Clear-sticky $checkout_path/\n";
694 print $state->{CVSROOT
} . "/$module/\n";
695 print "Clear-static-directory $checkout_path/\n";
696 print $state->{CVSROOT
} . "/$module/\n";
697 print "Clear-sticky $checkout_path/\n"; # yes, twice
698 print $state->{CVSROOT
} . "/$module/\n";
699 print "Template $checkout_path/\n";
700 print $state->{CVSROOT
} . "/$module/\n";
703 # instruct the client that we're checking out to $checkout_path
704 print "E cvs checkout: Updating $checkout_path\n";
711 my ($dir, $repodir, $remotedir, $seendirs) = @_;
712 my $parent = dirname
($dir);
715 $remotedir =~ s
|/+$||;
717 $log->debug("announcedir $dir, $repodir, $remotedir" );
719 if ($parent eq '.' || $parent eq './') {
722 # recurse to announce unseen parents first
723 if (length($parent) && !exists($seendirs->{$parent})) {
724 prepdir
($parent, $repodir, $remotedir, $seendirs);
726 # Announce that we are going to modify at the parent level
728 print "E cvs checkout: Updating $remotedir/$parent\n";
730 print "E cvs checkout: Updating $remotedir\n";
732 print "Clear-sticky $remotedir/$parent/\n";
733 print "$repodir/$parent/\n";
735 print "Clear-static-directory $remotedir/$dir/\n";
736 print "$repodir/$dir/\n";
737 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
738 print "$repodir/$parent/\n";
739 print "Template $remotedir/$dir/\n";
740 print "$repodir/$dir/\n";
743 $seendirs->{$dir} = 1;
746 foreach my $git ( @
{$updater->gethead} )
748 # Don't want to check out deleted files
749 next if ( $git->{filehash
} eq "deleted" );
751 ( $git->{name
}, $git->{dir
} ) = filenamesplit
($git->{name
});
753 if (length($git->{dir
}) && $git->{dir
} ne './'
754 && $git->{dir
} ne $lastdir ) {
755 unless (exists($seendirs{$git->{dir
}})) {
756 prepdir
($git->{dir
}, $state->{CVSROOT
} . "/$module/",
757 $checkout_path, \
%seendirs);
758 $lastdir = $git->{dir
};
759 $seendirs{$git->{dir
}} = 1;
761 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
764 # modification time of this file
765 print "Mod-time $git->{modified}\n";
767 # print some information to the client
768 if ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" )
770 print "M U $checkout_path/$git->{dir}$git->{name}\n";
772 print "M U $checkout_path/$git->{name}\n";
775 # instruct client we're sending a file to put in this path
776 print "Created $checkout_path/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "\n";
778 print $state->{CVSROOT
} . "/$module/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ?
$git->{dir
} . "/" : "" ) . "$git->{name}\n";
780 # this is an "entries" line
781 my $kopts = kopts_from_path
($git->{name
});
782 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
784 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
787 transmitfile
($git->{filehash
});
796 # Response expected: yes. Actually do a cvs update command. This uses any
797 # previous Argument, Directory, Entry, or Modified requests, if they have
798 # been sent. The last Directory sent specifies the working directory at the
799 # time of the operation. The -I option is not used--files which the client
800 # can decide whether to ignore are not mentioned and the client sends the
801 # Questionable request for others.
804 my ( $cmd, $data ) = @_;
806 $log->debug("req_update : " . ( defined($data) ?
$data : "[NULL]" ));
811 # It may just be a client exploring the available heads/modules
812 # in that case, list them as top level directories and leave it
813 # at that. Eclipse uses this technique to offer you a list of
814 # projects (heads in this case) to checkout.
816 if ($state->{module
} eq '') {
817 print "E cvs update: Updating .\n";
818 opendir HEADS
, $state->{CVSROOT
} . '/refs/heads';
819 while (my $head = readdir(HEADS
)) {
820 if (-f
$state->{CVSROOT
} . '/refs/heads/' . $head) {
821 print "E cvs update: New directory `$head'\n";
830 # Grab a handle to the SQLite db and do any necessary updates
831 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
835 argsfromdir
($updater);
837 #$log->debug("update state : " . Dumper($state));
839 # foreach file specified on the command line ...
840 foreach my $filename ( @
{$state->{args
}} )
842 $filename = filecleanup
($filename);
844 $log->debug("Processing file $filename");
846 # if we have a -C we should pretend we never saw modified stuff
847 if ( exists ( $state->{opt
}{C
} ) )
849 delete $state->{entries
}{$filename}{modified_hash
};
850 delete $state->{entries
}{$filename}{modified_filename
};
851 $state->{entries
}{$filename}{unchanged
} = 1;
855 if ( defined($state->{opt
}{r
}) and $state->{opt
}{r
} =~ /^1\.(\d+)/ )
857 $meta = $updater->getmeta($filename, $1);
859 $meta = $updater->getmeta($filename);
862 if ( ! defined $meta )
873 my $wrev = revparse
($filename);
875 # If the working copy is an old revision, lets get that version too for comparison.
876 if ( defined($wrev) and $wrev != $meta->{revision
} )
878 $oldmeta = $updater->getmeta($filename, $wrev);
881 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
883 # Files are up to date if the working copy and repo copy have the same revision,
884 # and the working copy is unmodified _and_ the user hasn't specified -C
885 next if ( defined ( $wrev )
886 and defined($meta->{revision
})
887 and $wrev == $meta->{revision
}
888 and $state->{entries
}{$filename}{unchanged
}
889 and not exists ( $state->{opt
}{C
} ) );
891 # If the working copy and repo copy have the same revision,
892 # but the working copy is modified, tell the client it's modified
893 if ( defined ( $wrev )
894 and defined($meta->{revision
})
895 and $wrev == $meta->{revision
}
896 and not exists ( $state->{opt
}{C
} ) )
898 $log->info("Tell the client the file is modified");
899 print "MT text M \n";
900 print "MT fname $filename\n";
901 print "MT newline\n";
905 if ( $meta->{filehash
} eq "deleted" )
907 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
909 $log->info("Removing '$filename' from working copy (no longer in the repo)");
911 print "E cvs update: `$filename' is no longer in the repository\n";
912 # Don't want to actually _DO_ the update if -n specified
913 unless ( $state->{globaloptions
}{-n
} ) {
914 print "Removed $dirpart\n";
918 elsif ( not defined ( $state->{entries
}{$filename}{modified_hash
} )
919 or $state->{entries
}{$filename}{modified_hash
} eq $oldmeta->{filehash
}
920 or $meta->{filehash
} eq 'added' )
922 # normal update, just send the new revision (either U=Update,
923 # or A=Add, or R=Remove)
924 if ( defined($wrev) && $wrev < 0 )
926 $log->info("Tell the client the file is scheduled for removal");
927 print "MT text R \n";
928 print "MT fname $filename\n";
929 print "MT newline\n";
932 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision
}) || $meta->{revision
} == 0) )
934 $log->info("Tell the client the file is scheduled for addition");
935 print "MT text A \n";
936 print "MT fname $filename\n";
937 print "MT newline\n";
942 $log->info("Updating '$filename' to ".$meta->{revision
});
943 print "MT +updated\n";
944 print "MT text U \n";
945 print "MT fname $filename\n";
946 print "MT newline\n";
947 print "MT -updated\n";
950 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
952 # Don't want to actually _DO_ the update if -n specified
953 unless ( $state->{globaloptions
}{-n
} )
955 if ( defined ( $wrev ) )
957 # instruct client we're sending a file to put in this path as a replacement
958 print "Update-existing $dirpart\n";
959 $log->debug("Updating existing file 'Update-existing $dirpart'");
961 # instruct client we're sending a file to put in this path as a new file
962 print "Clear-static-directory $dirpart\n";
963 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
964 print "Clear-sticky $dirpart\n";
965 print $state->{CVSROOT
} . "/$state->{module}/$dirpart\n";
967 $log->debug("Creating new file 'Created $dirpart'");
968 print "Created $dirpart\n";
970 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
972 # this is an "entries" line
973 my $kopts = kopts_from_path
($filepart);
974 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
975 print "/$filepart/1.$meta->{revision}//$kopts/\n";
978 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
979 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
982 transmitfile
($meta->{filehash
});
985 $log->info("Updating '$filename'");
986 my ( $filepart, $dirpart ) = filenamesplit
($meta->{name
},1);
988 my $dir = tempdir
( DIR
=> $TEMP_DIR, CLEANUP
=> 1 ) . "/";
991 my $file_local = $filepart . ".mine";
992 system("ln","-s",$state->{entries
}{$filename}{modified_filename
}, $file_local);
993 my $file_old = $filepart . "." . $oldmeta->{revision
};
994 transmitfile
($oldmeta->{filehash
}, $file_old);
995 my $file_new = $filepart . "." . $meta->{revision
};
996 transmitfile
($meta->{filehash
}, $file_new);
998 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
999 $log->info("Merging $file_local, $file_old, $file_new");
1000 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1002 $log->debug("Temporary directory for merge is $dir");
1004 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1009 $log->info("Merged successfully");
1010 print "M M $filename\n";
1011 $log->debug("Merged $dirpart");
1013 # Don't want to actually _DO_ the update if -n specified
1014 unless ( $state->{globaloptions
}{-n
} )
1016 print "Merged $dirpart\n";
1017 $log->debug($state->{CVSROOT
} . "/$state->{module}/$filename");
1018 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1019 my $kopts = kopts_from_path
($filepart);
1020 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1021 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1024 elsif ( $return == 1 )
1026 $log->info("Merged with conflicts");
1027 print "E cvs update: conflicts found in $filename\n";
1028 print "M C $filename\n";
1030 # Don't want to actually _DO_ the update if -n specified
1031 unless ( $state->{globaloptions
}{-n
} )
1033 print "Merged $dirpart\n";
1034 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1035 my $kopts = kopts_from_path
($filepart);
1036 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1041 $log->warn("Merge failed");
1045 # Don't want to actually _DO_ the update if -n specified
1046 unless ( $state->{globaloptions
}{-n
} )
1049 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1050 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1052 # transmit file, format is single integer on a line by itself (file
1053 # size) followed by the file contents
1054 # TODO : we should copy files in blocks
1055 my $data = `cat $file_local`;
1056 $log->debug("File size : " . length($data));
1057 print length($data) . "\n";
1071 my ( $cmd, $data ) = @_;
1075 #$log->debug("State : " . Dumper($state));
1077 $log->info("req_ci : " . ( defined($data) ?
$data : "[NULL]" ));
1079 if ( $state->{method
} eq 'pserver')
1081 print "error 1 pserver access cannot commit\n";
1085 if ( -e
$state->{CVSROOT
} . "/index" )
1087 $log->warn("file 'index' already exists in the git repository");
1088 print "error 1 Index already exists in git repo\n";
1092 # Grab a handle to the SQLite db and do any necessary updates
1093 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1096 my $tmpdir = tempdir
( DIR
=> $TEMP_DIR );
1097 my ( undef, $file_index ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1098 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1100 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
1101 $ENV{GIT_INDEX_FILE
} = $file_index;
1103 # Remember where the head was at the beginning.
1104 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1106 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1107 print "error 1 pserver cannot find the current HEAD of module";
1113 # populate the temporary index based
1114 system("git-read-tree", $parenthash);
1117 die "Error running git-read-tree $state->{module} $file_index $!";
1119 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1121 my @committedfiles = ();
1124 # foreach file specified on the command line ...
1125 foreach my $filename ( @
{$state->{args
}} )
1127 my $committedfile = $filename;
1128 $filename = filecleanup
($filename);
1130 next unless ( exists $state->{entries
}{$filename}{modified_filename
} or not $state->{entries
}{$filename}{unchanged
} );
1132 my $meta = $updater->getmeta($filename);
1133 $oldmeta{$filename} = $meta;
1135 my $wrev = revparse
($filename);
1137 my ( $filepart, $dirpart ) = filenamesplit
($filename);
1139 # do a checkout of the file if it part of this tree
1141 system('git-checkout-index', '-f', '-u', $filename);
1143 die "Error running git-checkout-index -f -u $filename : $!";
1149 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1150 $addflag = 1 unless ( -e
$filename );
1152 # Do up to date checking
1153 unless ( $addflag or $wrev == $meta->{revision
} or ( $rmflag and -$wrev == $meta->{revision
} ) )
1155 # fail everything if an up to date check fails
1156 print "error 1 Up to date check failed for $filename\n";
1161 push @committedfiles, $committedfile;
1162 $log->info("Committing $filename");
1164 system("mkdir","-p",$dirpart) unless ( -d
$dirpart );
1168 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1169 rename $state->{entries
}{$filename}{modified_filename
},$filename;
1171 # Calculate modes to remove
1173 foreach ( qw
(r w x
) ) { $invmode .= $_ unless ( $state->{entries
}{$filename}{modified_mode
} =~ /$_/ ); }
1175 $log->debug("chmod u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode . " $filename");
1176 system("chmod","u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode, $filename);
1181 $log->info("Removing file '$filename'");
1183 system("git-update-index", "--remove", $filename);
1187 $log->info("Adding file '$filename'");
1188 system("git-update-index", "--add", $filename);
1190 $log->info("Updating file '$filename'");
1191 system("git-update-index", $filename);
1195 unless ( scalar(@committedfiles) > 0 )
1197 print "E No files to commit\n";
1203 my $treehash = `git-write-tree`;
1206 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1208 # write our commit message out if we have one ...
1209 my ( $msg_fh, $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1210 print $msg_fh $state->{opt
}{m
};# if ( exists ( $state->{opt}{m} ) );
1211 print $msg_fh "\n\nvia git-CVS emulator\n";
1214 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1216 $log->info("Commit hash : $commithash");
1218 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1220 $log->warn("Commit failed (Invalid commit hash)");
1221 print "error 1 Commit failed (unknown reason)\n";
1226 # Check that this is allowed, just as we would with a receive-pack
1227 my @cmd = ( $ENV{GIT_DIR
}.'hooks/update', "refs/heads/$state->{module}",
1228 $parenthash, $commithash );
1230 unless( system( @cmd ) == 0 )
1232 $log->warn("Commit failed (update hook declined to update ref)");
1233 print "error 1 Commit failed (update hook declined)\n";
1239 if (system(qw(git update-ref -m), "cvsserver ci",
1240 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1241 $log->warn("update-ref for $state->{module} failed.");
1242 print "error 1 Cannot commit -- update first\n";
1248 # foreach file specified on the command line ...
1249 foreach my $filename ( @committedfiles )
1251 $filename = filecleanup
($filename);
1253 my $meta = $updater->getmeta($filename);
1254 unless (defined $meta->{revision
}) {
1255 $meta->{revision
} = 1;
1258 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
1260 $log->debug("Checked-in $dirpart : $filename");
1262 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1263 if ( defined $meta->{filehash
} && $meta->{filehash
} eq "deleted" )
1265 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1266 print "Remove-entry $dirpart\n";
1267 print "$filename\n";
1269 if ($meta->{revision
} == 1) {
1270 print "M initial revision: 1.1\n";
1272 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1274 print "Checked-in $dirpart\n";
1275 print "$filename\n";
1276 my $kopts = kopts_from_path
($filepart);
1277 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1287 my ( $cmd, $data ) = @_;
1291 $log->info("req_status : " . ( defined($data) ?
$data : "[NULL]" ));
1292 #$log->debug("status state : " . Dumper($state));
1294 # Grab a handle to the SQLite db and do any necessary updates
1295 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1298 # if no files were specified, we need to work out what files we should be providing status on ...
1299 argsfromdir
($updater);
1301 # foreach file specified on the command line ...
1302 foreach my $filename ( @
{$state->{args
}} )
1304 $filename = filecleanup
($filename);
1306 my $meta = $updater->getmeta($filename);
1307 my $oldmeta = $meta;
1309 my $wrev = revparse
($filename);
1311 # If the working copy is an old revision, lets get that version too for comparison.
1312 if ( defined($wrev) and $wrev != $meta->{revision
} )
1314 $oldmeta = $updater->getmeta($filename, $wrev);
1317 # TODO : All possible statuses aren't yet implemented
1319 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1320 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision
}) and $wrev == $meta->{revision
}
1322 ( ( $state->{entries
}{$filename}{unchanged
} and ( not defined ( $state->{entries
}{$filename}{conflict
} ) or $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) )
1323 or ( defined($state->{entries
}{$filename}{modified_hash
}) and $state->{entries
}{$filename}{modified_hash
} eq $meta->{filehash
} ) )
1326 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1327 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and $meta->{revision
} > $wrev
1329 ( $state->{entries
}{$filename}{unchanged
}
1330 or ( defined($state->{entries
}{$filename}{modified_hash
}) and $state->{entries
}{$filename}{modified_hash
} eq $oldmeta->{filehash
} ) )
1333 # Need checkout if it exists in the repo but doesn't have a working copy
1334 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision
} ) );
1336 # Locally modified if working copy and repo copy have the same revision but there are local changes
1337 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision
}) and $wrev == $meta->{revision
} and $state->{entries
}{$filename}{modified_filename
} );
1339 # Needs Merge if working copy revision is less than repo copy and there are local changes
1340 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and $meta->{revision
} > $wrev and $state->{entries
}{$filename}{modified_filename
} );
1342 $status ||= "Locally Added" if ( defined ( $state->{entries
}{$filename}{revision
} ) and not defined ( $meta->{revision
} ) );
1343 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and -$wrev == $meta->{revision
} );
1344 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries
}{$filename}{conflict
} ) and $state->{entries
}{$filename}{conflict
} =~ /^\+=/ );
1345 $status ||= "File had conflicts on merge" if ( 0 );
1347 $status ||= "Unknown";
1349 print "M ===================================================================\n";
1350 print "M File: $filename\tStatus: $status\n";
1351 if ( defined($state->{entries
}{$filename}{revision
}) )
1353 print "M Working revision:\t" . $state->{entries
}{$filename}{revision
} . "\n";
1355 print "M Working revision:\tNo entry for $filename\n";
1357 if ( defined($meta->{revision
}) )
1359 print "M Repository revision:\t1." . $meta->{revision
} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1360 print "M Sticky Tag:\t\t(none)\n";
1361 print "M Sticky Date:\t\t(none)\n";
1362 print "M Sticky Options:\t\t(none)\n";
1364 print "M Repository revision:\tNo revision control file\n";
1374 my ( $cmd, $data ) = @_;
1378 $log->debug("req_diff : " . ( defined($data) ?
$data : "[NULL]" ));
1379 #$log->debug("status state : " . Dumper($state));
1381 my ($revision1, $revision2);
1382 if ( defined ( $state->{opt
}{r
} ) and ref $state->{opt
}{r
} eq "ARRAY" )
1384 $revision1 = $state->{opt
}{r
}[0];
1385 $revision2 = $state->{opt
}{r
}[1];
1387 $revision1 = $state->{opt
}{r
};
1390 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1391 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1393 $log->debug("Diffing revisions " . ( defined($revision1) ?
$revision1 : "[NULL]" ) . " and " . ( defined($revision2) ?
$revision2 : "[NULL]" ) );
1395 # Grab a handle to the SQLite db and do any necessary updates
1396 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1399 # if no files were specified, we need to work out what files we should be providing status on ...
1400 argsfromdir
($updater);
1402 # foreach file specified on the command line ...
1403 foreach my $filename ( @
{$state->{args
}} )
1405 $filename = filecleanup
($filename);
1407 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1409 my $wrev = revparse
($filename);
1411 # We need _something_ to diff against
1412 next unless ( defined ( $wrev ) );
1414 # if we have a -r switch, use it
1415 if ( defined ( $revision1 ) )
1417 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1418 $meta1 = $updater->getmeta($filename, $revision1);
1419 unless ( defined ( $meta1 ) and $meta1->{filehash
} ne "deleted" )
1421 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1424 transmitfile
($meta1->{filehash
}, $file1);
1426 # otherwise we just use the working copy revision
1429 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1430 $meta1 = $updater->getmeta($filename, $wrev);
1431 transmitfile
($meta1->{filehash
}, $file1);
1434 # if we have a second -r switch, use it too
1435 if ( defined ( $revision2 ) )
1437 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1438 $meta2 = $updater->getmeta($filename, $revision2);
1440 unless ( defined ( $meta2 ) and $meta2->{filehash
} ne "deleted" )
1442 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1446 transmitfile
($meta2->{filehash
}, $file2);
1448 # otherwise we just use the working copy
1451 $file2 = $state->{entries
}{$filename}{modified_filename
};
1454 # if we have been given -r, and we don't have a $file2 yet, lets get one
1455 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1457 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1458 $meta2 = $updater->getmeta($filename, $wrev);
1459 transmitfile
($meta2->{filehash
}, $file2);
1462 # We need to have retrieved something useful
1463 next unless ( defined ( $meta1 ) );
1465 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1466 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision
}
1468 ( ( $state->{entries
}{$filename}{unchanged
} and ( not defined ( $state->{entries
}{$filename}{conflict
} ) or $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) )
1469 or ( defined($state->{entries
}{$filename}{modified_hash
}) and $state->{entries
}{$filename}{modified_hash
} eq $meta1->{filehash
} ) )
1472 # Apparently we only show diffs for locally modified files
1473 next unless ( defined($meta2) or defined ( $state->{entries
}{$filename}{modified_filename
} ) );
1475 print "M Index: $filename\n";
1476 print "M ===================================================================\n";
1477 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1478 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1479 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1481 foreach my $opt ( keys %{$state->{opt
}} )
1483 if ( ref $state->{opt
}{$opt} eq "ARRAY" )
1485 foreach my $value ( @
{$state->{opt
}{$opt}} )
1487 print "-$opt $value ";
1491 print "$state->{opt}{$opt} " if ( defined ( $state->{opt
}{$opt} ) );
1494 print "$filename\n";
1496 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision
} or "workingcopy" ));
1498 ( $fh, $filediff ) = tempfile
( DIR
=> $TEMP_DIR );
1500 if ( exists $state->{opt
}{u
} )
1502 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision
}) ?
"revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1504 system("diff $file1 $file2 > $filediff");
1519 my ( $cmd, $data ) = @_;
1523 $log->debug("req_log : " . ( defined($data) ?
$data : "[NULL]" ));
1524 #$log->debug("log state : " . Dumper($state));
1526 my ( $minrev, $maxrev );
1527 if ( defined ( $state->{opt
}{r
} ) and $state->{opt
}{r
} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1532 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1533 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1534 $minrev++ if ( defined($minrev) and $control eq "::" );
1537 # Grab a handle to the SQLite db and do any necessary updates
1538 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1541 # if no files were specified, we need to work out what files we should be providing status on ...
1542 argsfromdir
($updater);
1544 # foreach file specified on the command line ...
1545 foreach my $filename ( @
{$state->{args
}} )
1547 $filename = filecleanup
($filename);
1549 my $headmeta = $updater->getmeta($filename);
1551 my $revisions = $updater->getlog($filename);
1552 my $totalrevisions = scalar(@
$revisions);
1554 if ( defined ( $minrev ) )
1556 $log->debug("Removing revisions less than $minrev");
1557 while ( scalar(@
$revisions) > 0 and $revisions->[-1]{revision
} < $minrev )
1562 if ( defined ( $maxrev ) )
1564 $log->debug("Removing revisions greater than $maxrev");
1565 while ( scalar(@
$revisions) > 0 and $revisions->[0]{revision
} > $maxrev )
1571 next unless ( scalar(@
$revisions) );
1574 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1575 print "M Working file: $filename\n";
1576 print "M head: 1.$headmeta->{revision}\n";
1577 print "M branch:\n";
1578 print "M locks: strict\n";
1579 print "M access list:\n";
1580 print "M symbolic names:\n";
1581 print "M keyword substitution: kv\n";
1582 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@
$revisions) . "\n";
1583 print "M description:\n";
1585 foreach my $revision ( @
$revisions )
1587 print "M ----------------------------\n";
1588 print "M revision 1.$revision->{revision}\n";
1589 # reformat the date for log output
1590 $revision->{modified
} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified
} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1591 $revision->{author
} =~ s/\s+.*//;
1592 $revision->{author
} =~ s/^(.{8}).*/$1/;
1593 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash
} eq "deleted" ?
"dead" : "Exp" ) . "; lines: +2 -3\n";
1594 my $commitmessage = $updater->commitmessage($revision->{commithash
});
1595 $commitmessage =~ s/^/M /mg;
1596 print $commitmessage . "\n";
1598 print "M =============================================================================\n";
1606 my ( $cmd, $data ) = @_;
1608 argsplit
("annotate");
1610 $log->info("req_annotate : " . ( defined($data) ?
$data : "[NULL]" ));
1611 #$log->debug("status state : " . Dumper($state));
1613 # Grab a handle to the SQLite db and do any necessary updates
1614 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1617 # if no files were specified, we need to work out what files we should be providing annotate on ...
1618 argsfromdir
($updater);
1620 # we'll need a temporary checkout dir
1621 my $tmpdir = tempdir
( DIR
=> $TEMP_DIR );
1622 my ( undef, $file_index ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
1623 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1625 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
1626 $ENV{GIT_INDEX_FILE
} = $file_index;
1630 # foreach file specified on the command line ...
1631 foreach my $filename ( @
{$state->{args
}} )
1633 $filename = filecleanup
($filename);
1635 my $meta = $updater->getmeta($filename);
1637 next unless ( $meta->{revision
} );
1639 # get all the commits that this file was in
1640 # in dense format -- aka skip dead revisions
1641 my $revisions = $updater->gethistorydense($filename);
1642 my $lastseenin = $revisions->[0][2];
1644 # populate the temporary index based on the latest commit were we saw
1645 # the file -- but do it cheaply without checking out any files
1646 # TODO: if we got a revision from the client, use that instead
1647 # to look up the commithash in sqlite (still good to default to
1648 # the current head as we do now)
1649 system("git-read-tree", $lastseenin);
1652 die "Error running git-read-tree $lastseenin $file_index $!";
1654 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1656 # do a checkout of the file
1657 system('git-checkout-index', '-f', '-u', $filename);
1659 die "Error running git-checkout-index -f -u $filename : $!";
1662 $log->info("Annotate $filename");
1664 # Prepare a file with the commits from the linearized
1665 # history that annotate should know about. This prevents
1666 # git-jsannotate telling us about commits we are hiding
1669 open(ANNOTATEHINTS
, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1670 for (my $i=0; $i < @
$revisions; $i++)
1672 print ANNOTATEHINTS
$revisions->[$i][2];
1673 if ($i+1 < @
$revisions) { # have we got a parent?
1674 print ANNOTATEHINTS
' ' . $revisions->[$i+1][2];
1676 print ANNOTATEHINTS
"\n";
1679 print ANNOTATEHINTS
"\n";
1680 close ANNOTATEHINTS
;
1682 my $annotatecmd = 'git-annotate';
1683 open(ANNOTATE
, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1684 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1686 print "E Annotations for $filename\n";
1687 print "E ***************\n";
1688 while ( <ANNOTATE
> )
1690 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1692 my $commithash = $1;
1694 unless ( defined ( $metadata->{$commithash} ) )
1696 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1697 $metadata->{$commithash}{author
} =~ s/\s+.*//;
1698 $metadata->{$commithash}{author
} =~ s/^(.{8}).*/$1/;
1699 $metadata->{$commithash}{modified
} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1701 printf("M 1.%-5d (%-8s %10s): %s\n",
1702 $metadata->{$commithash}{revision
},
1703 $metadata->{$commithash}{author
},
1704 $metadata->{$commithash}{modified
},
1708 $log->warn("Error in annotate output! LINE: $_");
1709 print "E Annotate error \n";
1716 # done; get out of the tempdir
1723 # This method takes the state->{arguments} array and produces two new arrays.
1724 # The first is $state->{args} which is everything before the '--' argument, and
1725 # the second is $state->{files} which is everything after it.
1728 return unless( defined($state->{arguments
}) and ref $state->{arguments
} eq "ARRAY" );
1732 $state->{args
} = [];
1733 $state->{files
} = [];
1736 if ( defined($type) )
1739 $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" );
1740 $opt = { v
=> 0, l
=> 0, R
=> 0 } if ( $type eq "status" );
1741 $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" );
1742 $opt = { l
=> 0, R
=> 0, k
=> 1, D
=> 1, D
=> 1, r
=> 2 } if ( $type eq "diff" );
1743 $opt = { c
=> 0, R
=> 0, l
=> 0, f
=> 0, F
=> 1, m
=> 1, r
=> 1 } if ( $type eq "ci" );
1744 $opt = { k
=> 1, m
=> 1 } if ( $type eq "add" );
1745 $opt = { f
=> 0, l
=> 0, R
=> 0 } if ( $type eq "remove" );
1746 $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" );
1749 while ( scalar ( @
{$state->{arguments
}} ) > 0 )
1751 my $arg = shift @
{$state->{arguments
}};
1753 next if ( $arg eq "--" );
1754 next unless ( $arg =~ /\S/ );
1756 # if the argument looks like a switch
1757 if ( $arg =~ /^-(\w)(.*)/ )
1759 # if it's a switch that takes an argument
1762 # If this switch has already been provided
1763 if ( $opt->{$1} > 1 and exists ( $state->{opt
}{$1} ) )
1765 $state->{opt
}{$1} = [ $state->{opt
}{$1} ];
1766 if ( length($2) > 0 )
1768 push @
{$state->{opt
}{$1}},$2;
1770 push @
{$state->{opt
}{$1}}, shift @
{$state->{arguments
}};
1773 # if there's extra data in the arg, use that as the argument for the switch
1774 if ( length($2) > 0 )
1776 $state->{opt
}{$1} = $2;
1778 $state->{opt
}{$1} = shift @
{$state->{arguments
}};
1782 $state->{opt
}{$1} = undef;
1787 push @
{$state->{args
}}, $arg;
1795 foreach my $value ( @
{$state->{arguments
}} )
1797 if ( $value eq "--" )
1802 push @
{$state->{args
}}, $value if ( $mode == 0 );
1803 push @
{$state->{files
}}, $value if ( $mode == 1 );
1808 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1811 my $updater = shift;
1813 $state->{args
} = [] if ( scalar(@
{$state->{args
}}) == 1 and $state->{args
}[0] eq "." );
1815 return if ( scalar ( @
{$state->{args
}} ) > 1 );
1817 my @gethead = @
{$updater->gethead};
1820 foreach my $file (keys %{$state->{entries
}}) {
1821 if ( exists $state->{entries
}{$file}{revision
} &&
1822 $state->{entries
}{$file}{revision
} == 0 )
1824 push @gethead, { name
=> $file, filehash
=> 'added' };
1828 if ( scalar(@
{$state->{args
}}) == 1 )
1830 my $arg = $state->{args
}[0];
1831 $arg .= $state->{prependdir
} if ( defined ( $state->{prependdir
} ) );
1833 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1835 foreach my $file ( @gethead )
1837 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
1838 next unless ( $file->{name
} =~ /^$arg\// or $file->{name
} eq $arg );
1839 push @
{$state->{args
}}, $file->{name
};
1842 shift @
{$state->{args
}} if ( scalar(@
{$state->{args
}}) > 1 );
1844 $log->info("Only one arg specified, populating file list automatically");
1846 $state->{args
} = [];
1848 foreach my $file ( @gethead )
1850 next if ( $file->{filehash
} eq "deleted" and not defined ( $state->{entries
}{$file->{name
}} ) );
1851 next unless ( $file->{name
} =~ s/^$state->{prependdir}// );
1852 push @
{$state->{args
}}, $file->{name
};
1857 # This method cleans up the $state variable after a command that uses arguments has run
1860 $state->{files
} = [];
1861 $state->{args
} = [];
1862 $state->{arguments
} = [];
1863 $state->{entries
} = {};
1868 my $filename = shift;
1870 return undef unless ( defined ( $state->{entries
}{$filename}{revision
} ) );
1872 return $1 if ( $state->{entries
}{$filename}{revision
} =~ /^1\.(\d+)/ );
1873 return -$1 if ( $state->{entries
}{$filename}{revision
} =~ /^-1\.(\d+)/ );
1878 # This method takes a file hash and does a CVS "file transfer" which transmits the
1879 # size of the file, and then the file contents.
1880 # If a second argument $targetfile is given, the file is instead written out to
1881 # a file by the name of $targetfile
1884 my $filehash = shift;
1885 my $targetfile = shift;
1887 if ( defined ( $filehash ) and $filehash eq "deleted" )
1889 $log->warn("filehash is 'deleted'");
1893 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1895 my $type = `git-cat-file -t $filehash`;
1898 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1900 my $size = `git-cat-file -s $filehash`;
1903 $log->debug("transmitfile($filehash) size=$size, type=$type");
1905 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1907 if ( defined ( $targetfile ) )
1909 open NEWFILE
, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1910 print NEWFILE
$_ while ( <$fh> );
1914 print while ( <$fh> );
1916 close $fh or die ("Couldn't close filehandle for transmitfile()");
1918 die("Couldn't execute git-cat-file");
1922 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1923 # refers to the directory portion and the file portion of the filename
1927 my $filename = shift;
1928 my $fixforlocaldir = shift;
1930 my ( $filepart, $dirpart ) = ( $filename, "." );
1931 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1934 if ( $fixforlocaldir )
1936 $dirpart =~ s/^$state->{prependdir}//;
1939 return ( $filepart, $dirpart );
1944 my $filename = shift;
1946 return undef unless(defined($filename));
1947 if ( $filename =~ /^\// )
1949 print "E absolute filenames '$filename' not supported by server\n";
1953 $filename =~ s/^\.\///g
;
1954 $filename = $state->{prependdir
} . $filename;
1958 # Given a path, this function returns a string containing the kopts
1959 # that should go into that path's Entries line. For example, a binary
1960 # file should get -kb.
1965 # Once it exists, the git attributes system should be used to look up
1966 # what attributes apply to this path.
1968 # Until then, take the setting from the config file
1969 unless ( defined ( $cfg->{gitcvs
}{allbinary
} ) and $cfg->{gitcvs
}{allbinary
} =~ /^\s*(1|true|yes)\s*$/i )
1971 # Return "" to give no special treatment to any path
1974 # Alternatively, to have all files treated as if they are binary (which
1975 # is more like git itself), always return the "-kb" option
1980 package GITCVS
::log;
1983 #### Copyright The Open University UK - 2006.
1985 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1986 #### Martin Langhoff <martin@catalyst.net.nz>
1999 This module provides very crude logging with a similar interface to
2008 Creates a new log object, optionally you can specify a filename here to
2009 indicate the file to log to. If no log file is specified, you can specify one
2010 later with method setfile, or indicate you no longer want logging with method
2013 Until one of these methods is called, all log calls will buffer messages ready
2020 my $filename = shift;
2024 bless $self, $class;
2026 if ( defined ( $filename ) )
2028 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2036 This methods takes a filename, and attempts to open that file as the log file.
2037 If successful, all buffered data is written out to the file, and any further
2038 logging is written directly to the file.
2044 my $filename = shift;
2046 if ( defined ( $filename ) )
2048 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2051 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2053 while ( my $line = shift @
{$self->{buffer
}} )
2055 print {$self->{fh
}} $line;
2061 This method indicates no logging is going to be used. It flushes any entries in
2062 the internal buffer, and sets a flag to ensure no further data is put there.
2071 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
2073 $self->{buffer
} = [];
2078 Internal method. Returns true if the log file is open, false otherwise.
2085 return 1 if ( defined ( $self->{fh
} ) and ref $self->{fh
} eq "GLOB" );
2089 =head2 debug info warn fatal
2091 These four methods are wrappers to _log. They provide the actual interface for
2095 sub debug
{ my $self = shift; $self->_log("debug", @_); }
2096 sub info
{ my $self = shift; $self->_log("info" , @_); }
2097 sub warn { my $self = shift; $self->_log("warn" , @_); }
2098 sub fatal
{ my $self = shift; $self->_log("fatal", @_); }
2102 This is an internal method called by the logging functions. It generates a
2103 timestamp and pushes the logged line either to file, or internal buffer.
2111 return if ( $self->{nolog
} );
2113 my @time = localtime;
2114 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2124 if ( $self->_logopen )
2126 print {$self->{fh
}} $timestring . " - " . join(" ",@_) . "\n";
2128 push @
{$self->{buffer
}}, $timestring . " - " . join(" ",@_) . "\n";
2134 This method simply closes the file handle if one is open
2141 if ( $self->_logopen )
2147 package GITCVS
::updater
;
2150 #### Copyright The Open University UK - 2006.
2152 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2153 #### Martin Langhoff <martin@catalyst.net.nz>
2175 die "Need to specify a git repository" unless ( defined($config) and -d
$config );
2176 die "Need to specify a module" unless ( defined($module) );
2178 $class = ref($class) || $class;
2182 bless $self, $class;
2184 $self->{module
} = $module;
2185 $self->{git_path
} = $config . "/";
2187 $self->{log} = $log;
2189 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d
$self->{git_path
} );
2191 $self->{dbdriver
} = $cfg->{gitcvs
}{$state->{method
}}{dbdriver
} ||
2192 $cfg->{gitcvs
}{dbdriver
} || "SQLite";
2193 $self->{dbname
} = $cfg->{gitcvs
}{$state->{method
}}{dbname
} ||
2194 $cfg->{gitcvs
}{dbname
} || "%Ggitcvs.%m.sqlite";
2195 $self->{dbuser
} = $cfg->{gitcvs
}{$state->{method
}}{dbuser
} ||
2196 $cfg->{gitcvs
}{dbuser
} || "";
2197 $self->{dbpass
} = $cfg->{gitcvs
}{$state->{method
}}{dbpass
} ||
2198 $cfg->{gitcvs
}{dbpass
} || "";
2199 my %mapping = ( m
=> $module,
2200 a
=> $state->{method
},
2201 u
=> getlogin || getpwuid($<) || $<,
2202 G
=> $self->{git_path
},
2203 g
=> mangle_dirname
($self->{git_path
}),
2205 $self->{dbname
} =~ s/%([mauGg])/$mapping{$1}/eg;
2206 $self->{dbuser
} =~ s/%([mauGg])/$mapping{$1}/eg;
2208 die "Invalid char ':' in dbdriver" if $self->{dbdriver
} =~ /:/;
2209 die "Invalid char ';' in dbname" if $self->{dbname
} =~ /;/;
2210 $self->{dbh
} = DBI
->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2213 die "Error connecting to database\n" unless defined $self->{dbh
};
2215 $self->{tables
} = {};
2216 foreach my $table ( keys %{$self->{dbh
}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2218 $self->{tables
}{$table} = 1;
2221 # Construct the revision table if required
2222 unless ( $self->{tables
}{revision
} )
2225 CREATE TABLE revision (
2227 revision INTEGER NOT NULL,
2228 filehash TEXT NOT NULL,
2229 commithash TEXT NOT NULL,
2230 author TEXT NOT NULL,
2231 modified TEXT NOT NULL,
2236 CREATE INDEX revision_ix1
2237 ON revision (name,revision)
2240 CREATE INDEX revision_ix2
2241 ON revision (name,commithash)
2245 # Construct the head table if required
2246 unless ( $self->{tables
}{head
} )
2251 revision INTEGER NOT NULL,
2252 filehash TEXT NOT NULL,
2253 commithash TEXT NOT NULL,
2254 author TEXT NOT NULL,
2255 modified TEXT NOT NULL,
2260 CREATE INDEX head_ix1
2265 # Construct the properties table if required
2266 unless ( $self->{tables
}{properties
} )
2269 CREATE TABLE properties (
2270 key TEXT NOT NULL PRIMARY KEY,
2276 # Construct the commitmsgs table if required
2277 unless ( $self->{tables
}{commitmsgs
} )
2280 CREATE TABLE commitmsgs (
2281 key TEXT NOT NULL PRIMARY KEY,
2297 # first lets get the commit list
2298 $ENV{GIT_DIR
} = $self->{git_path
};
2300 my $commitsha1 = `git rev-parse $self->{module}`;
2303 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2304 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2306 die("Invalid module '$self->{module}'");
2311 my $lastcommit = $self->_get_prop("last_commit");
2313 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2317 # Start exclusive lock here...
2318 $self->{dbh
}->begin_work() or die "Cannot lock database for BEGIN";
2320 # TODO: log processing is memory bound
2321 # if we can parse into a 2nd file that is in reverse order
2322 # we can probably do something really efficient
2323 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2325 if (defined $lastcommit) {
2326 push @git_log_params, "$lastcommit..$self->{module}";
2328 push @git_log_params, $self->{module
};
2330 # git-rev-list is the backend / plumbing version of git-log
2331 open(GITLOG
, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2340 if (m/^commit\s+(.*)$/) {
2341 # on ^commit lines put the just seen commit in the stack
2342 # and prime things for the next one
2345 unshift @commits, \
%copy;
2348 my @parents = split(m/\s+/, $1);
2349 $commit{hash
} = shift @parents;
2350 $commit{parents
} = \
@parents;
2351 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message
})) {
2352 # on rfc822-like lines seen before we see any message,
2353 # lowercase the entry and put it in the hash as key-value
2354 $commit{lc($1)} = $2;
2356 # message lines - skip initial empty line
2357 # and trim whitespace
2358 if (!exists($commit{message
}) && m/^\s*$/) {
2359 # define it to mark the end of headers
2360 $commit{message
} = '';
2363 s/^\s+//; s/\s+$//; # trim ws
2364 $commit{message
} .= $_ . "\n";
2369 unshift @commits, \
%commit if ( keys %commit );
2371 # Now all the commits are in the @commits bucket
2372 # ordered by time DESC. for each commit that needs processing,
2373 # determine whether it's following the last head we've seen or if
2374 # it's on its own branch, grab a file list, and add whatever's changed
2375 # NOTE: $lastcommit refers to the last commit from previous run
2376 # $lastpicked is the last commit we picked in this run
2379 if (defined $lastcommit) {
2380 $lastpicked = $lastcommit;
2383 my $committotal = scalar(@commits);
2384 my $commitcount = 0;
2386 # Load the head table into $head (for cached lookups during the update process)
2387 foreach my $file ( @
{$self->gethead()} )
2389 $head->{$file->{name
}} = $file;
2392 foreach my $commit ( @commits )
2394 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2395 if (defined $lastpicked)
2397 if (!in_array
($lastpicked, @
{$commit->{parents
}}))
2399 # skip, we'll see this delta
2400 # as part of a merge later
2401 # warn "skipping off-track $commit->{hash}\n";
2403 } elsif (@
{$commit->{parents
}} > 1) {
2404 # it is a merge commit, for each parent that is
2405 # not $lastpicked, see if we can get a log
2406 # from the merge-base to that parent to put it
2407 # in the message as a merge summary.
2408 my @parents = @
{$commit->{parents
}};
2409 foreach my $parent (@parents) {
2410 # git-merge-base can potentially (but rarely) throw
2411 # several candidate merge bases. let's assume
2412 # that the first one is the best one.
2413 if ($parent eq $lastpicked) {
2416 open my $p, 'git-merge-base '. $lastpicked . ' '
2418 my @output = (<$p>);
2420 my $base = join('', @output);
2424 # print "want to log between $base $parent \n";
2425 open(GITLOG
, '-|', 'git-log', "$base..$parent")
2426 or die "Cannot call git-log: $!";
2430 if (!defined $mergedhash) {
2431 if (m/^commit\s+(.+)$/) {
2437 # grab the first line that looks non-rfc822
2438 # aka has content after leading space
2439 if (m/^\s+(\S.*)$/) {
2441 $title = substr($title,0,100); # truncate
2442 unshift @merged, "$mergedhash $title";
2449 $commit->{mergemsg
} = $commit->{message
};
2450 $commit->{mergemsg
} .= "\nSummary of merged commits:\n\n";
2451 foreach my $summary (@merged) {
2452 $commit->{mergemsg
} .= "\t$summary\n";
2454 $commit->{mergemsg
} .= "\n\n";
2455 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2462 # convert the date to CVS-happy format
2463 $commit->{date
} = "$2 $1 $4 $3 $5" if ( $commit->{date
} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2465 if ( defined ( $lastpicked ) )
2467 my $filepipe = open(FILELIST
, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash
}) or die("Cannot call git-diff-tree : $!");
2469 while ( <FILELIST
> )
2472 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2474 die("Couldn't process git-diff-tree line : $_");
2476 my ($mode, $hash, $change) = ($1, $2, $3);
2477 my $name = <FILELIST
>;
2480 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2483 $git_perms .= "r" if ( $mode & 4 );
2484 $git_perms .= "w" if ( $mode & 2 );
2485 $git_perms .= "x" if ( $mode & 1 );
2486 $git_perms = "rw" if ( $git_perms eq "" );
2488 if ( $change eq "D" )
2490 #$log->debug("DELETE $name");
2493 revision
=> $head->{$name}{revision
} + 1,
2494 filehash
=> "deleted",
2495 commithash
=> $commit->{hash
},
2496 modified
=> $commit->{date
},
2497 author
=> $commit->{author
},
2500 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
2502 elsif ( $change eq "M" )
2504 #$log->debug("MODIFIED $name");
2507 revision
=> $head->{$name}{revision
} + 1,
2509 commithash
=> $commit->{hash
},
2510 modified
=> $commit->{date
},
2511 author
=> $commit->{author
},
2514 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
2516 elsif ( $change eq "A" )
2518 #$log->debug("ADDED $name");
2523 commithash
=> $commit->{hash
},
2524 modified
=> $commit->{date
},
2525 author
=> $commit->{author
},
2528 $self->insert_rev($name, $head->{$name}{revision
}, $hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
2532 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2538 # this is used to detect files removed from the repo
2539 my $seen_files = {};
2541 my $filepipe = open(FILELIST
, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash
}) or die("Cannot call git-ls-tree : $!");
2543 while ( <FILELIST
> )
2546 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2548 die("Couldn't process git-ls-tree line : $_");
2551 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2553 $seen_files->{$git_filename} = 1;
2555 my ( $oldhash, $oldrevision, $oldmode ) = (
2556 $head->{$git_filename}{filehash
},
2557 $head->{$git_filename}{revision
},
2558 $head->{$git_filename}{mode
}
2561 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2564 $git_perms .= "r" if ( $1 & 4 );
2565 $git_perms .= "w" if ( $1 & 2 );
2566 $git_perms .= "x" if ( $1 & 1 );
2571 # unless the file exists with the same hash, we need to update it ...
2572 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2574 my $newrevision = ( $oldrevision or 0 ) + 1;
2576 $head->{$git_filename} = {
2577 name
=> $git_filename,
2578 revision
=> $newrevision,
2579 filehash
=> $git_hash,
2580 commithash
=> $commit->{hash
},
2581 modified
=> $commit->{date
},
2582 author
=> $commit->{author
},
2587 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $git_perms);
2592 # Detect deleted files
2593 foreach my $file ( keys %$head )
2595 unless ( exists $seen_files->{$file} or $head->{$file}{filehash
} eq "deleted" )
2597 $head->{$file}{revision
}++;
2598 $head->{$file}{filehash
} = "deleted";
2599 $head->{$file}{commithash
} = $commit->{hash
};
2600 $head->{$file}{modified
} = $commit->{date
};
2601 $head->{$file}{author
} = $commit->{author
};
2603 $self->insert_rev($file, $head->{$file}{revision
}, $head->{$file}{filehash
}, $commit->{hash
}, $commit->{date
}, $commit->{author
}, $head->{$file}{mode
});
2606 # END : "Detect deleted files"
2610 if (exists $commit->{mergemsg
})
2612 $self->insert_mergelog($commit->{hash
}, $commit->{mergemsg
});
2615 $lastpicked = $commit->{hash
};
2617 $self->_set_prop("last_commit", $commit->{hash
});
2620 $self->delete_head();
2621 foreach my $file ( keys %$head )
2625 $head->{$file}{revision
},
2626 $head->{$file}{filehash
},
2627 $head->{$file}{commithash
},
2628 $head->{$file}{modified
},
2629 $head->{$file}{author
},
2630 $head->{$file}{mode
},
2633 # invalidate the gethead cache
2634 $self->{gethead_cache
} = undef;
2637 # Ending exclusive lock here
2638 $self->{dbh
}->commit() or die "Failed to commit changes to SQLite";
2645 my $revision = shift;
2646 my $filehash = shift;
2647 my $commithash = shift;
2648 my $modified = shift;
2652 my $insert_rev = $self->{dbh
}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2653 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2662 my $insert_mergelog = $self->{dbh
}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2663 $insert_mergelog->execute($key, $value);
2670 my $delete_head = $self->{dbh
}->prepare_cached("DELETE FROM head",{},1);
2671 $delete_head->execute();
2678 my $revision = shift;
2679 my $filehash = shift;
2680 my $commithash = shift;
2681 my $modified = shift;
2685 my $insert_head = $self->{dbh
}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2686 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2692 my $filename = shift;
2694 my $db_query = $self->{dbh
}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2695 $db_query->execute($filename);
2696 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2698 return ( $hash, $revision, $mode );
2706 my $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2707 $db_query->execute($key);
2708 my ( $value ) = $db_query->fetchrow_array;
2719 my $db_query = $self->{dbh
}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2720 $db_query->execute($value, $key);
2722 unless ( $db_query->rows )
2724 $db_query = $self->{dbh
}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2725 $db_query->execute($key, $value);
2739 return $self->{gethead_cache
} if ( defined ( $self->{gethead_cache
} ) );
2741 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2742 $db_query->execute();
2745 while ( my $file = $db_query->fetchrow_hashref )
2750 $self->{gethead_cache
} = $tree;
2762 my $filename = shift;
2764 my $db_query = $self->{dbh
}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2765 $db_query->execute($filename);
2768 while ( my $file = $db_query->fetchrow_hashref )
2778 This function takes a filename (with path) argument and returns a hashref of
2779 metadata for that file.
2786 my $filename = shift;
2787 my $revision = shift;
2790 if ( defined($revision) and $revision =~ /^\d+$/ )
2792 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2793 $db_query->execute($filename, $revision);
2795 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2797 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2798 $db_query->execute($filename, $revision);
2800 $db_query = $self->{dbh
}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2801 $db_query->execute($filename);
2804 return $db_query->fetchrow_hashref;
2807 =head2 commitmessage
2809 this function takes a commithash and returns the commit message for that commit
2815 my $commithash = shift;
2817 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2820 $db_query = $self->{dbh
}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2821 $db_query->execute($commithash);
2823 my ( $message ) = $db_query->fetchrow_array;
2825 if ( defined ( $message ) )
2827 $message .= " " if ( $message =~ /\n$/ );
2831 my @lines = safe_pipe_capture
("git-cat-file", "commit", $commithash);
2832 shift @lines while ( $lines[0] =~ /\S/ );
2833 $message = join("",@lines);
2834 $message .= " " if ( $message =~ /\n$/ );
2840 This function takes a filename (with path) argument and returns an arrayofarrays
2841 containing revision,filehash,commithash ordered by revision descending
2847 my $filename = shift;
2850 $db_query = $self->{dbh
}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2851 $db_query->execute($filename);
2853 return $db_query->fetchall_arrayref;
2856 =head2 gethistorydense
2858 This function takes a filename (with path) argument and returns an arrayofarrays
2859 containing revision,filehash,commithash ordered by revision descending.
2861 This version of gethistory skips deleted entries -- so it is useful for annotate.
2862 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2863 and other git tools that depend on it.
2869 my $filename = shift;
2872 $db_query = $self->{dbh
}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2873 $db_query->execute($filename);
2875 return $db_query->fetchall_arrayref;
2880 from Array::PAT - mimics the in_array() function
2881 found in PHP. Yuck but works for small arrays.
2886 my ($check, @array) = @_;
2888 foreach my $test (@array){
2889 if($check eq $test){
2896 =head2 safe_pipe_capture
2898 an alternative to `command` that allows input to be passed as an array
2899 to work around shell problems with weird characters in arguments
2902 sub safe_pipe_capture
{
2906 if (my $pid = open my $child, '-|') {
2907 @output = (<$child>);
2908 close $child or die join(' ',@_).": $! $?";
2910 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2912 return wantarray ?
@output : join('',@output);
2915 =head2 mangle_dirname
2917 create a string from a directory name that is suitable to use as
2918 part of a filename, mainly by converting all chars except \w.- to _
2921 sub mangle_dirname
{
2922 my $dirname = shift;
2923 return unless defined $dirname;
2925 $dirname =~ s/[^\w.-]/_/g;