1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
21 use Fcntl;
22 use File::Temp qw/tempdir tempfile/;
23 use File::Basename;
25 my $log = GITCVS::log->new();
26 my $cfg;
28 my $DATE_LIST = {
29 Jan => "01",
30 Feb => "02",
31 Mar => "03",
32 Apr => "04",
33 May => "05",
34 Jun => "06",
35 Jul => "07",
36 Aug => "08",
37 Sep => "09",
38 Oct => "10",
39 Nov => "11",
40 Dec => "12",
41 };
43 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
44 $| = 1;
46 #### Definition and mappings of functions ####
48 my $methods = {
49 'Root' => \&req_Root,
50 'Valid-responses' => \&req_Validresponses,
51 'valid-requests' => \&req_validrequests,
52 'Directory' => \&req_Directory,
53 'Entry' => \&req_Entry,
54 'Modified' => \&req_Modified,
55 'Unchanged' => \&req_Unchanged,
56 'Questionable' => \&req_Questionable,
57 'Argument' => \&req_Argument,
58 'Argumentx' => \&req_Argument,
59 'expand-modules' => \&req_expandmodules,
60 'add' => \&req_add,
61 'remove' => \&req_remove,
62 'co' => \&req_co,
63 'update' => \&req_update,
64 'ci' => \&req_ci,
65 'diff' => \&req_diff,
66 'log' => \&req_log,
67 'rlog' => \&req_log,
68 'tag' => \&req_CATCHALL,
69 'status' => \&req_status,
70 'admin' => \&req_CATCHALL,
71 'history' => \&req_CATCHALL,
72 'watchers' => \&req_CATCHALL,
73 'editors' => \&req_CATCHALL,
74 'annotate' => \&req_annotate,
75 'Global_option' => \&req_Globaloption,
76 #'annotate' => \&req_CATCHALL,
77 };
79 ##############################################
82 # $state holds all the bits of information the clients sends us that could
83 # potentially be useful when it comes to actually _doing_ something.
84 my $state = {};
85 $log->info("--------------- STARTING -----------------");
87 my $TEMP_DIR = tempdir( CLEANUP => 1 );
88 $log->debug("Temporary directory is '$TEMP_DIR'");
90 # Keep going until the client closes the connection
91 while (<STDIN>)
92 {
93 chomp;
95 # Check to see if we've seen this method, and call appropiate function.
96 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
97 {
98 # use the $methods hash to call the appropriate sub for this command
99 #$log->info("Method : $1");
100 &{$methods->{$1}}($1,$2);
101 } else {
102 # log fatal because we don't understand this function. If this happens
103 # we're fairly screwed because we don't know if the client is expecting
104 # a response. If it is, the client will hang, we'll hang, and the whole
105 # thing will be custard.
106 $log->fatal("Don't understand command $_\n");
107 die("Unknown command $_");
108 }
109 }
111 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
112 $log->info("--------------- FINISH -----------------");
114 # Magic catchall method.
115 # This is the method that will handle all commands we haven't yet
116 # implemented. It simply sends a warning to the log file indicating a
117 # command that hasn't been implemented has been invoked.
118 sub req_CATCHALL
119 {
120 my ( $cmd, $data ) = @_;
121 $log->warn("Unhandled command : req_$cmd : $data");
122 }
125 # Root pathname \n
126 # Response expected: no. Tell the server which CVSROOT to use. Note that
127 # pathname is a local directory and not a fully qualified CVSROOT variable.
128 # pathname must already exist; if creating a new root, use the init
129 # request, not Root. pathname does not include the hostname of the server,
130 # how to access the server, etc.; by the time the CVS protocol is in use,
131 # connection, authentication, etc., are already taken care of. The Root
132 # request must be sent only once, and it must be sent before any requests
133 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
134 sub req_Root
135 {
136 my ( $cmd, $data ) = @_;
137 $log->debug("req_Root : $data");
139 $state->{CVSROOT} = $data;
141 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
143 foreach my $line ( `git-var -l` )
144 {
145 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
146 $cfg->{$1}{$2} = $3;
147 }
149 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
150 {
151 print "E GITCVS emulation needs to be enabled on this repo\n";
152 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
153 print "E \n";
154 print "error 1 GITCVS emulation disabled\n";
155 }
157 if ( defined ( $cfg->{gitcvs}{logfile} ) )
158 {
159 $log->setfile($cfg->{gitcvs}{logfile});
160 } else {
161 $log->nofile();
162 }
163 }
165 # Global_option option \n
166 # Response expected: no. Transmit one of the global options `-q', `-Q',
167 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
168 # variations (such as combining of options) are allowed. For graceful
169 # handling of valid-requests, it is probably better to make new global
170 # options separate requests, rather than trying to add them to this
171 # request.
172 sub req_Globaloption
173 {
174 my ( $cmd, $data ) = @_;
175 $log->debug("req_Globaloption : $data");
177 # TODO : is this data useful ???
178 }
180 # Valid-responses request-list \n
181 # Response expected: no. Tell the server what responses the client will
182 # accept. request-list is a space separated list of tokens.
183 sub req_Validresponses
184 {
185 my ( $cmd, $data ) = @_;
186 $log->debug("req_Validrepsonses : $data");
188 # TODO : re-enable this, currently it's not particularly useful
189 #$state->{validresponses} = [ split /\s+/, $data ];
190 }
192 # valid-requests \n
193 # Response expected: yes. Ask the server to send back a Valid-requests
194 # response.
195 sub req_validrequests
196 {
197 my ( $cmd, $data ) = @_;
199 $log->debug("req_validrequests");
201 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
202 $log->debug("SEND : ok");
204 print "Valid-requests " . join(" ",keys %$methods) . "\n";
205 print "ok\n";
206 }
208 # Directory local-directory \n
209 # Additional data: repository \n. Response expected: no. Tell the server
210 # what directory to use. The repository should be a directory name from a
211 # previous server response. Note that this both gives a default for Entry
212 # and Modified and also for ci and the other commands; normal usage is to
213 # send Directory for each directory in which there will be an Entry or
214 # Modified, and then a final Directory for the original directory, then the
215 # command. The local-directory is relative to the top level at which the
216 # command is occurring (i.e. the last Directory which is sent before the
217 # command); to indicate that top level, `.' should be sent for
218 # local-directory.
219 sub req_Directory
220 {
221 my ( $cmd, $data ) = @_;
223 my $repository = <STDIN>;
224 chomp $repository;
227 $state->{localdir} = $data;
228 $state->{repository} = $repository;
229 $state->{directory} = $repository;
230 $state->{directory} =~ s/^$state->{CVSROOT}\///;
231 $state->{module} = $1 if ($state->{directory} =~ s/^(.*?)(\/|$)//);
232 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
234 $log->debug("req_Directory : localdir=$data repository=$repository directory=$state->{directory} module=$state->{module}");
235 }
237 # Entry entry-line \n
238 # Response expected: no. Tell the server what version of a file is on the
239 # local machine. The name in entry-line is a name relative to the directory
240 # most recently specified with Directory. If the user is operating on only
241 # some files in a directory, Entry requests for only those files need be
242 # included. If an Entry request is sent without Modified, Is-modified, or
243 # Unchanged, it means the file is lost (does not exist in the working
244 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
245 # are sent for the same file, Entry must be sent first. For a given file,
246 # one can send Modified, Is-modified, or Unchanged, but not more than one
247 # of these three.
248 sub req_Entry
249 {
250 my ( $cmd, $data ) = @_;
252 $log->debug("req_Entry : $data");
254 my @data = split(/\//, $data);
256 $state->{entries}{$state->{directory}.$data[1]} = {
257 revision => $data[2],
258 conflict => $data[3],
259 options => $data[4],
260 tag_or_date => $data[5],
261 };
262 }
264 # add \n
265 # Response expected: yes. Add a file or directory. This uses any previous
266 # Argument, Directory, Entry, or Modified requests, if they have been sent.
267 # The last Directory sent specifies the working directory at the time of
268 # the operation. To add a directory, send the directory to be added using
269 # Directory and Argument requests.
270 sub req_add
271 {
272 my ( $cmd, $data ) = @_;
274 argsplit("add");
276 my $addcount = 0;
278 foreach my $filename ( @{$state->{args}} )
279 {
280 $filename = filecleanup($filename);
282 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
283 {
284 print "E cvs add: nothing known about `$filename'\n";
285 next;
286 }
287 # TODO : check we're not squashing an already existing file
288 if ( defined ( $state->{entries}{$filename}{revision} ) )
289 {
290 print "E cvs add: `$filename' has already been entered\n";
291 next;
292 }
295 my ( $filepart, $dirpart ) = filenamesplit($filename);
297 print "E cvs add: scheduling file `$filename' for addition\n";
299 print "Checked-in $dirpart\n";
300 print "$filename\n";
301 print "/$filepart/0///\n";
303 $addcount++;
304 }
306 if ( $addcount == 1 )
307 {
308 print "E cvs add: use `cvs commit' to add this file permanently\n";
309 }
310 elsif ( $addcount > 1 )
311 {
312 print "E cvs add: use `cvs commit' to add these files permanently\n";
313 }
315 print "ok\n";
316 }
318 # remove \n
319 # Response expected: yes. Remove a file. This uses any previous Argument,
320 # Directory, Entry, or Modified requests, if they have been sent. The last
321 # Directory sent specifies the working directory at the time of the
322 # operation. Note that this request does not actually do anything to the
323 # repository; the only effect of a successful remove request is to supply
324 # the client with a new entries line containing `-' to indicate a removed
325 # file. In fact, the client probably could perform this operation without
326 # contacting the server, although using remove may cause the server to
327 # perform a few more checks. The client sends a subsequent ci request to
328 # actually record the removal in the repository.
329 sub req_remove
330 {
331 my ( $cmd, $data ) = @_;
333 argsplit("remove");
335 # Grab a handle to the SQLite db and do any necessary updates
336 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
337 $updater->update();
339 #$log->debug("add state : " . Dumper($state));
341 my $rmcount = 0;
343 foreach my $filename ( @{$state->{args}} )
344 {
345 $filename = filecleanup($filename);
347 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
348 {
349 print "E cvs remove: file `$filename' still in working directory\n";
350 next;
351 }
353 my $meta = $updater->getmeta($filename);
354 my $wrev = revparse($filename);
356 unless ( defined ( $wrev ) )
357 {
358 print "E cvs remove: nothing known about `$filename'\n";
359 next;
360 }
362 if ( defined($wrev) and $wrev < 0 )
363 {
364 print "E cvs remove: file `$filename' already scheduled for removal\n";
365 next;
366 }
368 unless ( $wrev == $meta->{revision} )
369 {
370 # TODO : not sure if the format of this message is quite correct.
371 print "E cvs remove: Up to date check failed for `$filename'\n";
372 next;
373 }
376 my ( $filepart, $dirpart ) = filenamesplit($filename);
378 print "E cvs remove: scheduling `$filename' for removal\n";
380 print "Checked-in $dirpart\n";
381 print "$filename\n";
382 print "/$filepart/-1.$wrev///\n";
384 $rmcount++;
385 }
387 if ( $rmcount == 1 )
388 {
389 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
390 }
391 elsif ( $rmcount > 1 )
392 {
393 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
394 }
396 print "ok\n";
397 }
399 # Modified filename \n
400 # Response expected: no. Additional data: mode, \n, file transmission. Send
401 # the server a copy of one locally modified file. filename is a file within
402 # the most recent directory sent with Directory; it must not contain `/'.
403 # If the user is operating on only some files in a directory, only those
404 # files need to be included. This can also be sent without Entry, if there
405 # is no entry for the file.
406 sub req_Modified
407 {
408 my ( $cmd, $data ) = @_;
410 my $mode = <STDIN>;
411 chomp $mode;
412 my $size = <STDIN>;
413 chomp $size;
415 # Grab config information
416 my $blocksize = 8192;
417 my $bytesleft = $size;
418 my $tmp;
420 # Get a filehandle/name to write it to
421 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
423 # Loop over file data writing out to temporary file.
424 while ( $bytesleft )
425 {
426 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
427 read STDIN, $tmp, $blocksize;
428 print $fh $tmp;
429 $bytesleft -= $blocksize;
430 }
432 close $fh;
434 # Ensure we have something sensible for the file mode
435 if ( $mode =~ /u=(\w+)/ )
436 {
437 $mode = $1;
438 } else {
439 $mode = "rw";
440 }
442 # Save the file data in $state
443 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
444 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
445 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
446 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
448 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
449 }
451 # Unchanged filename \n
452 # Response expected: no. Tell the server that filename has not been
453 # modified in the checked out directory. The filename is a file within the
454 # most recent directory sent with Directory; it must not contain `/'.
455 sub req_Unchanged
456 {
457 my ( $cmd, $data ) = @_;
459 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
461 #$log->debug("req_Unchanged : $data");
462 }
464 # Questionable filename \n
465 # Response expected: no. Additional data: no.
466 # Tell the server to check whether filename should be ignored,
467 # and if not, next time the server sends responses, send (in
468 # a M response) `?' followed by the directory and filename.
469 # filename must not contain `/'; it needs to be a file in the
470 # directory named by the most recent Directory request.
471 sub req_Questionable
472 {
473 my ( $cmd, $data ) = @_;
475 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
477 #$log->debug("req_Questionable : $data");
478 }
480 # Argument text \n
481 # Response expected: no. Save argument for use in a subsequent command.
482 # Arguments accumulate until an argument-using command is given, at which
483 # point they are forgotten.
484 # Argumentx text \n
485 # Response expected: no. Append \n followed by text to the current argument
486 # being saved.
487 sub req_Argument
488 {
489 my ( $cmd, $data ) = @_;
491 # TODO : Not quite sure how Argument and Argumentx differ, but I assume
492 # it's for multi-line arguments ... somehow ...
494 $log->debug("$cmd : $data");
496 push @{$state->{arguments}}, $data;
497 }
499 # expand-modules \n
500 # Response expected: yes. Expand the modules which are specified in the
501 # arguments. Returns the data in Module-expansion responses. Note that the
502 # server can assume that this is checkout or export, not rtag or rdiff; the
503 # latter do not access the working directory and thus have no need to
504 # expand modules on the client side. Expand may not be the best word for
505 # what this request does. It does not necessarily tell you all the files
506 # contained in a module, for example. Basically it is a way of telling you
507 # which working directories the server needs to know about in order to
508 # handle a checkout of the specified modules. For example, suppose that the
509 # server has a module defined by
510 # aliasmodule -a 1dir
511 # That is, one can check out aliasmodule and it will take 1dir in the
512 # repository and check it out to 1dir in the working directory. Now suppose
513 # the client already has this module checked out and is planning on using
514 # the co request to update it. Without using expand-modules, the client
515 # would have two bad choices: it could either send information about all
516 # working directories under the current directory, which could be
517 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
518 # stands for 1dir, and neglect to send information for 1dir, which would
519 # lead to incorrect operation. With expand-modules, the client would first
520 # ask for the module to be expanded:
521 sub req_expandmodules
522 {
523 my ( $cmd, $data ) = @_;
525 argsplit();
527 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
529 unless ( ref $state->{arguments} eq "ARRAY" )
530 {
531 print "ok\n";
532 return;
533 }
535 foreach my $module ( @{$state->{arguments}} )
536 {
537 $log->debug("SEND : Module-expansion $module");
538 print "Module-expansion $module\n";
539 }
541 print "ok\n";
542 statecleanup();
543 }
545 # co \n
546 # Response expected: yes. Get files from the repository. This uses any
547 # previous Argument, Directory, Entry, or Modified requests, if they have
548 # been sent. Arguments to this command are module names; the client cannot
549 # know what directories they correspond to except by (1) just sending the
550 # co request, and then seeing what directory names the server sends back in
551 # its responses, and (2) the expand-modules request.
552 sub req_co
553 {
554 my ( $cmd, $data ) = @_;
556 argsplit("co");
558 my $module = $state->{args}[0];
559 my $checkout_path = $module;
561 # use the user specified directory if we're given it
562 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
564 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
566 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
568 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
570 # Grab a handle to the SQLite db and do any necessary updates
571 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
572 $updater->update();
574 # instruct the client that we're checking out to $checkout_path
575 print "E cvs server: updating $checkout_path\n";
577 foreach my $git ( @{$updater->gethead} )
578 {
579 # Don't want to check out deleted files
580 next if ( $git->{filehash} eq "deleted" );
582 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
584 # modification time of this file
585 print "Mod-time $git->{modified}\n";
587 # print some information to the client
588 print "MT +updated\n";
589 print "MT text U \n";
590 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
591 {
592 print "MT fname $checkout_path/$git->{dir}$git->{name}\n";
593 } else {
594 print "MT fname $checkout_path/$git->{name}\n";
595 }
596 print "MT newline\n";
597 print "MT -updated\n";
599 # instruct client we're sending a file to put in this path
600 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
602 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
604 # this is an "entries" line
605 print "/$git->{name}/1.$git->{revision}///\n";
606 # permissions
607 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
609 # transmit file
610 transmitfile($git->{filehash});
611 }
613 print "ok\n";
615 statecleanup();
616 }
618 # update \n
619 # Response expected: yes. Actually do a cvs update command. This uses any
620 # previous Argument, Directory, Entry, or Modified requests, if they have
621 # been sent. The last Directory sent specifies the working directory at the
622 # time of the operation. The -I option is not used--files which the client
623 # can decide whether to ignore are not mentioned and the client sends the
624 # Questionable request for others.
625 sub req_update
626 {
627 my ( $cmd, $data ) = @_;
629 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
631 argsplit("update");
633 # Grab a handle to the SQLite db and do any necessary updates
634 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
636 $updater->update();
638 # if no files were specified, we need to work out what files we should be providing status on ...
639 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
641 #$log->debug("update state : " . Dumper($state));
643 # foreach file specified on the commandline ...
644 foreach my $filename ( @{$state->{args}} )
645 {
646 $filename = filecleanup($filename);
648 # if we have a -C we should pretend we never saw modified stuff
649 if ( exists ( $state->{opt}{C} ) )
650 {
651 delete $state->{entries}{$filename}{modified_hash};
652 delete $state->{entries}{$filename}{modified_filename};
653 $state->{entries}{$filename}{unchanged} = 1;
654 }
656 my $meta;
657 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
658 {
659 $meta = $updater->getmeta($filename, $1);
660 } else {
661 $meta = $updater->getmeta($filename);
662 }
664 next unless ( $meta->{revision} );
666 my $oldmeta = $meta;
668 my $wrev = revparse($filename);
670 # If the working copy is an old revision, lets get that version too for comparison.
671 if ( defined($wrev) and $wrev != $meta->{revision} )
672 {
673 $oldmeta = $updater->getmeta($filename, $wrev);
674 }
676 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
678 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified _and_ the user hasn't specified -C
679 next if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{unchanged} and not exists ( $state->{opt}{C} ) );
681 if ( $meta->{filehash} eq "deleted" )
682 {
683 my ( $filepart, $dirpart ) = filenamesplit($filename);
685 $log->info("Removing '$filename' from working copy (no longer in the repo)");
687 print "E cvs update: `$filename' is no longer in the repository\n";
688 print "Removed $dirpart\n";
689 print "$filepart\n";
690 }
691 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} ) or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
692 {
693 $log->info("Updating '$filename'");
694 # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
695 print "MT +updated\n";
696 print "MT text U\n";
697 print "MT fname $filename\n";
698 print "MT newline\n";
699 print "MT -updated\n";
701 my ( $filepart, $dirpart ) = filenamesplit($filename);
702 $dirpart =~ s/^$state->{directory}//;
704 if ( defined ( $wrev ) )
705 {
706 # instruct client we're sending a file to put in this path as a replacement
707 print "Update-existing $dirpart\n";
708 $log->debug("Updating existing file 'Update-existing $dirpart'");
709 } else {
710 # instruct client we're sending a file to put in this path as a new file
711 print "Created $dirpart\n";
712 $log->debug("Creating new file 'Created $dirpart'");
713 }
714 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
716 # this is an "entries" line
717 $log->debug("/$filepart/1.$meta->{revision}///");
718 print "/$filepart/1.$meta->{revision}///\n";
720 # permissions
721 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
722 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
724 # transmit file
725 transmitfile($meta->{filehash});
726 } else {
727 my ( $filepart, $dirpart ) = filenamesplit($meta->{name});
729 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
731 chdir $dir;
732 my $file_local = $filepart . ".mine";
733 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
734 my $file_old = $filepart . "." . $oldmeta->{revision};
735 transmitfile($oldmeta->{filehash}, $file_old);
736 my $file_new = $filepart . "." . $meta->{revision};
737 transmitfile($meta->{filehash}, $file_new);
739 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
740 $log->info("Merging $file_local, $file_old, $file_new");
742 $log->debug("Temporary directory for merge is $dir");
744 my $return = system("merge", $file_local, $file_old, $file_new);
745 $return >>= 8;
747 if ( $return == 0 )
748 {
749 $log->info("Merged successfully");
750 print "M M $filename\n";
751 $log->debug("Update-existing $dirpart");
752 print "Update-existing $dirpart\n";
753 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
754 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
755 $log->debug("/$filepart/1.$meta->{revision}///");
756 print "/$filepart/1.$meta->{revision}///\n";
757 }
758 elsif ( $return == 1 )
759 {
760 $log->info("Merged with conflicts");
761 print "M C $filename\n";
762 print "Update-existing $dirpart\n";
763 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
764 print "/$filepart/1.$meta->{revision}/+//\n";
765 }
766 else
767 {
768 $log->warn("Merge failed");
769 next;
770 }
772 # permissions
773 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
774 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
776 # transmit file, format is single integer on a line by itself (file
777 # size) followed by the file contents
778 # TODO : we should copy files in blocks
779 my $data = `cat $file_local`;
780 $log->debug("File size : " . length($data));
781 print length($data) . "\n";
782 print $data;
784 chdir "/";
785 }
787 }
789 print "ok\n";
790 }
792 sub req_ci
793 {
794 my ( $cmd, $data ) = @_;
796 argsplit("ci");
798 #$log->debug("State : " . Dumper($state));
800 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
802 if ( -e $state->{CVSROOT} . "/index" )
803 {
804 print "error 1 Index already exists in git repo\n";
805 exit;
806 }
808 my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
809 unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
810 {
811 print "error 1 Lock file '$lockfile' already exists, please try again\n";
812 exit;
813 }
815 # Grab a handle to the SQLite db and do any necessary updates
816 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
817 $updater->update();
819 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
820 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
821 $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
823 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
824 $ENV{GIT_INDEX_FILE} = $file_index;
826 chdir $tmpdir;
828 # populate the temporary index based
829 system("git-read-tree", $state->{module});
830 unless ($? == 0)
831 {
832 die "Error running git-read-tree $state->{module} $file_index $!";
833 }
834 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
837 my @committedfiles = ();
839 # foreach file specified on the commandline ...
840 foreach my $filename ( @{$state->{args}} )
841 {
842 $filename = filecleanup($filename);
844 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
846 my $meta = $updater->getmeta($filename);
848 my $wrev = revparse($filename);
850 my ( $filepart, $dirpart ) = filenamesplit($filename);
852 # do a checkout of the file if it part of this tree
853 if ($wrev) {
854 system('git-checkout-index', '-f', '-u', $filename);
855 unless ($? == 0) {
856 die "Error running git-checkout-index -f -u $filename : $!";
857 }
858 }
860 my $addflag = 0;
861 my $rmflag = 0;
862 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
863 $addflag = 1 unless ( -e $filename );
865 # Do up to date checking
866 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
867 {
868 # fail everything if an up to date check fails
869 print "error 1 Up to date check failed for $filename\n";
870 close LOCKFILE;
871 unlink($lockfile);
872 chdir "/";
873 exit;
874 }
876 push @committedfiles, $filename;
877 $log->info("Committing $filename");
879 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
881 unless ( $rmflag )
882 {
883 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
884 rename $state->{entries}{$filename}{modified_filename},$filename;
886 # Calculate modes to remove
887 my $invmode = "";
888 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
890 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
891 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
892 }
894 if ( $rmflag )
895 {
896 $log->info("Removing file '$filename'");
897 unlink($filename);
898 system("git-update-index", "--remove", $filename);
899 }
900 elsif ( $addflag )
901 {
902 $log->info("Adding file '$filename'");
903 system("git-update-index", "--add", $filename);
904 } else {
905 $log->info("Updating file '$filename'");
906 system("git-update-index", $filename);
907 }
908 }
910 unless ( scalar(@committedfiles) > 0 )
911 {
912 print "E No files to commit\n";
913 print "ok\n";
914 close LOCKFILE;
915 unlink($lockfile);
916 chdir "/";
917 return;
918 }
920 my $treehash = `git-write-tree`;
921 my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
922 chomp $treehash;
923 chomp $parenthash;
925 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
927 # write our commit message out if we have one ...
928 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
929 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
930 print $msg_fh "\n\nvia git-CVS emulator\n";
931 close $msg_fh;
933 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
934 $log->info("Commit hash : $commithash");
936 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
937 {
938 $log->warn("Commit failed (Invalid commit hash)");
939 print "error 1 Commit failed (unknown reason)\n";
940 close LOCKFILE;
941 unlink($lockfile);
942 chdir "/";
943 exit;
944 }
946 open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
947 print FILE $commithash;
948 close FILE;
950 $updater->update();
952 # foreach file specified on the commandline ...
953 foreach my $filename ( @committedfiles )
954 {
955 $filename = filecleanup($filename);
957 my $meta = $updater->getmeta($filename);
959 my ( $filepart, $dirpart ) = filenamesplit($filename);
961 $log->debug("Checked-in $dirpart : $filename");
963 if ( $meta->{filehash} eq "deleted" )
964 {
965 print "Remove-entry $dirpart\n";
966 print "$filename\n";
967 } else {
968 print "Checked-in $dirpart\n";
969 print "$filename\n";
970 print "/$filepart/1.$meta->{revision}///\n";
971 }
972 }
974 close LOCKFILE;
975 unlink($lockfile);
976 chdir "/";
978 print "ok\n";
979 }
981 sub req_status
982 {
983 my ( $cmd, $data ) = @_;
985 argsplit("status");
987 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
988 #$log->debug("status state : " . Dumper($state));
990 # Grab a handle to the SQLite db and do any necessary updates
991 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
992 $updater->update();
994 # if no files were specified, we need to work out what files we should be providing status on ...
995 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
997 # foreach file specified on the commandline ...
998 foreach my $filename ( @{$state->{args}} )
999 {
1000 $filename = filecleanup($filename);
1002 my $meta = $updater->getmeta($filename);
1003 my $oldmeta = $meta;
1005 my $wrev = revparse($filename);
1007 # If the working copy is an old revision, lets get that version too for comparison.
1008 if ( defined($wrev) and $wrev != $meta->{revision} )
1009 {
1010 $oldmeta = $updater->getmeta($filename, $wrev);
1011 }
1013 # TODO : All possible statuses aren't yet implemented
1014 my $status;
1015 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1016 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1017 and
1018 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1019 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1020 );
1022 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1023 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1024 and
1025 ( $state->{entries}{$filename}{unchanged}
1026 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1027 );
1029 # Need checkout if it exists in the repo but doesn't have a working copy
1030 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1032 # Locally modified if working copy and repo copy have the same revision but there are local changes
1033 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1035 # Needs Merge if working copy revision is less than repo copy and there are local changes
1036 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1038 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1039 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1040 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1041 $status ||= "File had conflicts on merge" if ( 0 );
1043 $status ||= "Unknown";
1045 print "M ===================================================================\n";
1046 print "M File: $filename\tStatus: $status\n";
1047 if ( defined($state->{entries}{$filename}{revision}) )
1048 {
1049 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1050 } else {
1051 print "M Working revision:\tNo entry for $filename\n";
1052 }
1053 if ( defined($meta->{revision}) )
1054 {
1055 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1056 print "M Sticky Tag:\t\t(none)\n";
1057 print "M Sticky Date:\t\t(none)\n";
1058 print "M Sticky Options:\t\t(none)\n";
1059 } else {
1060 print "M Repository revision:\tNo revision control file\n";
1061 }
1062 print "M\n";
1063 }
1065 print "ok\n";
1066 }
1068 sub req_diff
1069 {
1070 my ( $cmd, $data ) = @_;
1072 argsplit("diff");
1074 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1075 #$log->debug("status state : " . Dumper($state));
1077 my ($revision1, $revision2);
1078 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1079 {
1080 $revision1 = $state->{opt}{r}[0];
1081 $revision2 = $state->{opt}{r}[1];
1082 } else {
1083 $revision1 = $state->{opt}{r};
1084 }
1086 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1087 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1089 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1091 # Grab a handle to the SQLite db and do any necessary updates
1092 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1093 $updater->update();
1095 # if no files were specified, we need to work out what files we should be providing status on ...
1096 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1098 # foreach file specified on the commandline ...
1099 foreach my $filename ( @{$state->{args}} )
1100 {
1101 $filename = filecleanup($filename);
1103 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1105 my $wrev = revparse($filename);
1107 # We need _something_ to diff against
1108 next unless ( defined ( $wrev ) );
1110 # if we have a -r switch, use it
1111 if ( defined ( $revision1 ) )
1112 {
1113 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1114 $meta1 = $updater->getmeta($filename, $revision1);
1115 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1116 {
1117 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1118 next;
1119 }
1120 transmitfile($meta1->{filehash}, $file1);
1121 }
1122 # otherwise we just use the working copy revision
1123 else
1124 {
1125 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1126 $meta1 = $updater->getmeta($filename, $wrev);
1127 transmitfile($meta1->{filehash}, $file1);
1128 }
1130 # if we have a second -r switch, use it too
1131 if ( defined ( $revision2 ) )
1132 {
1133 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1134 $meta2 = $updater->getmeta($filename, $revision2);
1136 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1137 {
1138 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1139 next;
1140 }
1142 transmitfile($meta2->{filehash}, $file2);
1143 }
1144 # otherwise we just use the working copy
1145 else
1146 {
1147 $file2 = $state->{entries}{$filename}{modified_filename};
1148 }
1150 # if we have been given -r, and we don't have a $file2 yet, lets get one
1151 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1152 {
1153 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1154 $meta2 = $updater->getmeta($filename, $wrev);
1155 transmitfile($meta2->{filehash}, $file2);
1156 }
1158 # We need to have retrieved something useful
1159 next unless ( defined ( $meta1 ) );
1161 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1162 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1163 and
1164 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1165 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1166 );
1168 # Apparently we only show diffs for locally modified files
1169 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1171 print "M Index: $filename\n";
1172 print "M ===================================================================\n";
1173 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1174 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1175 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1176 print "M diff ";
1177 foreach my $opt ( keys %{$state->{opt}} )
1178 {
1179 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1180 {
1181 foreach my $value ( @{$state->{opt}{$opt}} )
1182 {
1183 print "-$opt $value ";
1184 }
1185 } else {
1186 print "-$opt ";
1187 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1188 }
1189 }
1190 print "$filename\n";
1192 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1194 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1196 if ( exists $state->{opt}{u} )
1197 {
1198 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1199 } else {
1200 system("diff $file1 $file2 > $filediff");
1201 }
1203 while ( <$fh> )
1204 {
1205 print "M $_";
1206 }
1207 close $fh;
1208 }
1210 print "ok\n";
1211 }
1213 sub req_log
1214 {
1215 my ( $cmd, $data ) = @_;
1217 argsplit("log");
1219 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1220 #$log->debug("log state : " . Dumper($state));
1222 my ( $minrev, $maxrev );
1223 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1224 {
1225 my $control = $2;
1226 $minrev = $1;
1227 $maxrev = $3;
1228 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1229 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1230 $minrev++ if ( defined($minrev) and $control eq "::" );
1231 }
1233 # Grab a handle to the SQLite db and do any necessary updates
1234 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1235 $updater->update();
1237 # if no files were specified, we need to work out what files we should be providing status on ...
1238 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1240 # foreach file specified on the commandline ...
1241 foreach my $filename ( @{$state->{args}} )
1242 {
1243 $filename = filecleanup($filename);
1245 my $headmeta = $updater->getmeta($filename);
1247 my $revisions = $updater->getlog($filename);
1248 my $totalrevisions = scalar(@$revisions);
1250 if ( defined ( $minrev ) )
1251 {
1252 $log->debug("Removing revisions less than $minrev");
1253 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1254 {
1255 pop @$revisions;
1256 }
1257 }
1258 if ( defined ( $maxrev ) )
1259 {
1260 $log->debug("Removing revisions greater than $maxrev");
1261 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1262 {
1263 shift @$revisions;
1264 }
1265 }
1267 next unless ( scalar(@$revisions) );
1269 print "M \n";
1270 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1271 print "M Working file: $filename\n";
1272 print "M head: 1.$headmeta->{revision}\n";
1273 print "M branch:\n";
1274 print "M locks: strict\n";
1275 print "M access list:\n";
1276 print "M symbolic names:\n";
1277 print "M keyword substitution: kv\n";
1278 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1279 print "M description:\n";
1281 foreach my $revision ( @$revisions )
1282 {
1283 print "M ----------------------------\n";
1284 print "M revision 1.$revision->{revision}\n";
1285 # reformat the date for log output
1286 $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}) );
1287 $revision->{author} =~ s/\s+.*//;
1288 $revision->{author} =~ s/^(.{8}).*/$1/;
1289 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1290 my $commitmessage = $updater->commitmessage($revision->{commithash});
1291 $commitmessage =~ s/^/M /mg;
1292 print $commitmessage . "\n";
1293 }
1294 print "M =============================================================================\n";
1295 }
1297 print "ok\n";
1298 }
1300 sub req_annotate
1301 {
1302 my ( $cmd, $data ) = @_;
1304 argsplit("annotate");
1306 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1307 #$log->debug("status state : " . Dumper($state));
1309 # Grab a handle to the SQLite db and do any necessary updates
1310 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1311 $updater->update();
1313 # if no files were specified, we need to work out what files we should be providing annotate on ...
1314 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1316 # we'll need a temporary checkout dir
1317 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1318 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1319 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1321 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1322 $ENV{GIT_INDEX_FILE} = $file_index;
1324 chdir $tmpdir;
1326 # foreach file specified on the commandline ...
1327 foreach my $filename ( @{$state->{args}} )
1328 {
1329 $filename = filecleanup($filename);
1331 my $meta = $updater->getmeta($filename);
1333 next unless ( $meta->{revision} );
1335 # get all the commits that this file was in
1336 # in dense format -- aka skip dead revisions
1337 my $revisions = $updater->gethistorydense($filename);
1338 my $lastseenin = $revisions->[0][2];
1340 # populate the temporary index based on the latest commit were we saw
1341 # the file -- but do it cheaply without checking out any files
1342 # TODO: if we got a revision from the client, use that instead
1343 # to look up the commithash in sqlite (still good to default to
1344 # the current head as we do now)
1345 system("git-read-tree", $lastseenin);
1346 unless ($? == 0)
1347 {
1348 die "Error running git-read-tree $lastseenin $file_index $!";
1349 }
1350 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1352 # do a checkout of the file
1353 system('git-checkout-index', '-f', '-u', $filename);
1354 unless ($? == 0) {
1355 die "Error running git-checkout-index -f -u $filename : $!";
1356 }
1358 $log->info("Annotate $filename");
1360 # Prepare a file with the commits from the linearized
1361 # history that annotate should know about. This prevents
1362 # git-jsannotate telling us about commits we are hiding
1363 # from the client.
1365 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1366 for (my $i=0; $i < @$revisions; $i++)
1367 {
1368 print ANNOTATEHINTS $revisions->[$i][2];
1369 if ($i+1 < @$revisions) { # have we got a parent?
1370 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1371 }
1372 print ANNOTATEHINTS "\n";
1373 }
1375 print ANNOTATEHINTS "\n";
1376 close ANNOTATEHINTS;
1378 my $annotatecmd = 'git-annotate';
1379 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1380 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1381 my $metadata = {};
1382 print "E Annotations for $filename\n";
1383 print "E ***************\n";
1384 while ( <ANNOTATE> )
1385 {
1386 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1387 {
1388 my $commithash = $1;
1389 my $data = $2;
1390 unless ( defined ( $metadata->{$commithash} ) )
1391 {
1392 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1393 $metadata->{$commithash}{author} =~ s/\s+.*//;
1394 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1395 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1396 }
1397 printf("M 1.%-5d (%-8s %10s): %s\n",
1398 $metadata->{$commithash}{revision},
1399 $metadata->{$commithash}{author},
1400 $metadata->{$commithash}{modified},
1401 $data
1402 );
1403 } else {
1404 $log->warn("Error in annotate output! LINE: $_");
1405 print "E Annotate error \n";
1406 next;
1407 }
1408 }
1409 close ANNOTATE;
1410 }
1412 # done; get out of the tempdir
1413 chdir "/";
1415 print "ok\n";
1417 }
1419 # This method takes the state->{arguments} array and produces two new arrays.
1420 # The first is $state->{args} which is everything before the '--' argument, and
1421 # the second is $state->{files} which is everything after it.
1422 sub argsplit
1423 {
1424 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1426 my $type = shift;
1428 $state->{args} = [];
1429 $state->{files} = [];
1430 $state->{opt} = {};
1432 if ( defined($type) )
1433 {
1434 my $opt = {};
1435 $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" );
1436 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1437 $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" );
1438 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1439 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1440 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1441 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1442 $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" );
1445 while ( scalar ( @{$state->{arguments}} ) > 0 )
1446 {
1447 my $arg = shift @{$state->{arguments}};
1449 next if ( $arg eq "--" );
1450 next unless ( $arg =~ /\S/ );
1452 # if the argument looks like a switch
1453 if ( $arg =~ /^-(\w)(.*)/ )
1454 {
1455 # if it's a switch that takes an argument
1456 if ( $opt->{$1} )
1457 {
1458 # If this switch has already been provided
1459 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1460 {
1461 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1462 if ( length($2) > 0 )
1463 {
1464 push @{$state->{opt}{$1}},$2;
1465 } else {
1466 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1467 }
1468 } else {
1469 # if there's extra data in the arg, use that as the argument for the switch
1470 if ( length($2) > 0 )
1471 {
1472 $state->{opt}{$1} = $2;
1473 } else {
1474 $state->{opt}{$1} = shift @{$state->{arguments}};
1475 }
1476 }
1477 } else {
1478 $state->{opt}{$1} = undef;
1479 }
1480 }
1481 else
1482 {
1483 push @{$state->{args}}, $arg;
1484 }
1485 }
1486 }
1487 else
1488 {
1489 my $mode = 0;
1491 foreach my $value ( @{$state->{arguments}} )
1492 {
1493 if ( $value eq "--" )
1494 {
1495 $mode++;
1496 next;
1497 }
1498 push @{$state->{args}}, $value if ( $mode == 0 );
1499 push @{$state->{files}}, $value if ( $mode == 1 );
1500 }
1501 }
1502 }
1504 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1505 sub argsfromdir
1506 {
1507 my $updater = shift;
1509 $state->{args} = [];
1511 foreach my $file ( @{$updater->gethead} )
1512 {
1513 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1514 next unless ( $file->{name} =~ s/^$state->{directory}// );
1515 push @{$state->{args}}, $file->{name};
1516 }
1517 }
1519 # This method cleans up the $state variable after a command that uses arguments has run
1520 sub statecleanup
1521 {
1522 $state->{files} = [];
1523 $state->{args} = [];
1524 $state->{arguments} = [];
1525 $state->{entries} = {};
1526 }
1528 sub revparse
1529 {
1530 my $filename = shift;
1532 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1534 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1535 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1537 return undef;
1538 }
1540 # This method takes a file hash and does a CVS "file transfer" which transmits the
1541 # size of the file, and then the file contents.
1542 # If a second argument $targetfile is given, the file is instead written out to
1543 # a file by the name of $targetfile
1544 sub transmitfile
1545 {
1546 my $filehash = shift;
1547 my $targetfile = shift;
1549 if ( defined ( $filehash ) and $filehash eq "deleted" )
1550 {
1551 $log->warn("filehash is 'deleted'");
1552 return;
1553 }
1555 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1557 my $type = `git-cat-file -t $filehash`;
1558 chomp $type;
1560 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1562 my $size = `git-cat-file -s $filehash`;
1563 chomp $size;
1565 $log->debug("transmitfile($filehash) size=$size, type=$type");
1567 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1568 {
1569 if ( defined ( $targetfile ) )
1570 {
1571 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1572 print NEWFILE $_ while ( <$fh> );
1573 close NEWFILE;
1574 } else {
1575 print "$size\n";
1576 print while ( <$fh> );
1577 }
1578 close $fh or die ("Couldn't close filehandle for transmitfile()");
1579 } else {
1580 die("Couldn't execute git-cat-file");
1581 }
1582 }
1584 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1585 # refers to the directory porition and the file portion of the filename
1586 # respectively
1587 sub filenamesplit
1588 {
1589 my $filename = shift;
1591 my ( $filepart, $dirpart ) = ( $filename, "." );
1592 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1593 $dirpart .= "/";
1595 return ( $filepart, $dirpart );
1596 }
1598 sub filecleanup
1599 {
1600 my $filename = shift;
1602 return undef unless(defined($filename));
1603 if ( $filename =~ /^\// )
1604 {
1605 print "E absolute filenames '$filename' not supported by server\n";
1606 return undef;
1607 }
1609 $filename =~ s/^\.\///g;
1610 $filename = $state->{directory} . $filename;
1612 return $filename;
1613 }
1615 package GITCVS::log;
1617 ####
1618 #### Copyright The Open University UK - 2006.
1619 ####
1620 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1621 #### Martin Langhoff <martin@catalyst.net.nz>
1622 ####
1623 ####
1625 use strict;
1626 use warnings;
1628 =head1 NAME
1630 GITCVS::log
1632 =head1 DESCRIPTION
1634 This module provides very crude logging with a similar interface to
1635 Log::Log4perl
1637 =head1 METHODS
1639 =cut
1641 =head2 new
1643 Creates a new log object, optionally you can specify a filename here to
1644 indicate the file to log to. If no log file is specified, you can specifiy one
1645 later with method setfile, or indicate you no longer want logging with method
1646 nofile.
1648 Until one of these methods is called, all log calls will buffer messages ready
1649 to write out.
1651 =cut
1652 sub new
1653 {
1654 my $class = shift;
1655 my $filename = shift;
1657 my $self = {};
1659 bless $self, $class;
1661 if ( defined ( $filename ) )
1662 {
1663 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1664 }
1666 return $self;
1667 }
1669 =head2 setfile
1671 This methods takes a filename, and attempts to open that file as the log file.
1672 If successful, all buffered data is written out to the file, and any further
1673 logging is written directly to the file.
1675 =cut
1676 sub setfile
1677 {
1678 my $self = shift;
1679 my $filename = shift;
1681 if ( defined ( $filename ) )
1682 {
1683 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1684 }
1686 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1688 while ( my $line = shift @{$self->{buffer}} )
1689 {
1690 print {$self->{fh}} $line;
1691 }
1692 }
1694 =head2 nofile
1696 This method indicates no logging is going to be used. It flushes any entries in
1697 the internal buffer, and sets a flag to ensure no further data is put there.
1699 =cut
1700 sub nofile
1701 {
1702 my $self = shift;
1704 $self->{nolog} = 1;
1706 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1708 $self->{buffer} = [];
1709 }
1711 =head2 _logopen
1713 Internal method. Returns true if the log file is open, false otherwise.
1715 =cut
1716 sub _logopen
1717 {
1718 my $self = shift;
1720 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1721 return 0;
1722 }
1724 =head2 debug info warn fatal
1726 These four methods are wrappers to _log. They provide the actual interface for
1727 logging data.
1729 =cut
1730 sub debug { my $self = shift; $self->_log("debug", @_); }
1731 sub info { my $self = shift; $self->_log("info" , @_); }
1732 sub warn { my $self = shift; $self->_log("warn" , @_); }
1733 sub fatal { my $self = shift; $self->_log("fatal", @_); }
1735 =head2 _log
1737 This is an internal method called by the logging functions. It generates a
1738 timestamp and pushes the logged line either to file, or internal buffer.
1740 =cut
1741 sub _log
1742 {
1743 my $self = shift;
1744 my $level = shift;
1746 return if ( $self->{nolog} );
1748 my @time = localtime;
1749 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1750 $time[5] + 1900,
1751 $time[4] + 1,
1752 $time[3],
1753 $time[2],
1754 $time[1],
1755 $time[0],
1756 uc $level,
1757 );
1759 if ( $self->_logopen )
1760 {
1761 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1762 } else {
1763 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1764 }
1765 }
1767 =head2 DESTROY
1769 This method simply closes the file handle if one is open
1771 =cut
1772 sub DESTROY
1773 {
1774 my $self = shift;
1776 if ( $self->_logopen )
1777 {
1778 close $self->{fh};
1779 }
1780 }
1782 package GITCVS::updater;
1784 ####
1785 #### Copyright The Open University UK - 2006.
1786 ####
1787 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1788 #### Martin Langhoff <martin@catalyst.net.nz>
1789 ####
1790 ####
1792 use strict;
1793 use warnings;
1794 use DBI;
1796 =head1 METHODS
1798 =cut
1800 =head2 new
1802 =cut
1803 sub new
1804 {
1805 my $class = shift;
1806 my $config = shift;
1807 my $module = shift;
1808 my $log = shift;
1810 die "Need to specify a git repository" unless ( defined($config) and -d $config );
1811 die "Need to specify a module" unless ( defined($module) );
1813 $class = ref($class) || $class;
1815 my $self = {};
1817 bless $self, $class;
1819 $self->{dbdir} = $config . "/";
1820 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
1822 $self->{module} = $module;
1823 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
1825 $self->{git_path} = $config . "/";
1827 $self->{log} = $log;
1829 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
1831 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
1833 $self->{tables} = {};
1834 foreach my $table ( $self->{dbh}->tables )
1835 {
1836 $table =~ s/^"//;
1837 $table =~ s/"$//;
1838 $self->{tables}{$table} = 1;
1839 }
1841 # Construct the revision table if required
1842 unless ( $self->{tables}{revision} )
1843 {
1844 $self->{dbh}->do("
1845 CREATE TABLE revision (
1846 name TEXT NOT NULL,
1847 revision INTEGER NOT NULL,
1848 filehash TEXT NOT NULL,
1849 commithash TEXT NOT NULL,
1850 author TEXT NOT NULL,
1851 modified TEXT NOT NULL,
1852 mode TEXT NOT NULL
1853 )
1854 ");
1855 }
1857 # Construct the revision table if required
1858 unless ( $self->{tables}{head} )
1859 {
1860 $self->{dbh}->do("
1861 CREATE TABLE head (
1862 name TEXT NOT NULL,
1863 revision INTEGER NOT NULL,
1864 filehash TEXT NOT NULL,
1865 commithash TEXT NOT NULL,
1866 author TEXT NOT NULL,
1867 modified TEXT NOT NULL,
1868 mode TEXT NOT NULL
1869 )
1870 ");
1871 }
1873 # Construct the properties table if required
1874 unless ( $self->{tables}{properties} )
1875 {
1876 $self->{dbh}->do("
1877 CREATE TABLE properties (
1878 key TEXT NOT NULL PRIMARY KEY,
1879 value TEXT
1880 )
1881 ");
1882 }
1884 # Construct the commitmsgs table if required
1885 unless ( $self->{tables}{commitmsgs} )
1886 {
1887 $self->{dbh}->do("
1888 CREATE TABLE commitmsgs (
1889 key TEXT NOT NULL PRIMARY KEY,
1890 value TEXT
1891 )
1892 ");
1893 }
1895 return $self;
1896 }
1898 =head2 update
1900 =cut
1901 sub update
1902 {
1903 my $self = shift;
1905 # first lets get the commit list
1906 $ENV{GIT_DIR} = $self->{git_path};
1908 # prepare database queries
1909 my $db_insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1910 my $db_insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
1911 my $db_delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
1912 my $db_insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1914 my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
1915 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
1916 {
1917 die("Invalid module '$self->{module}'");
1918 }
1921 my $git_log;
1922 my $lastcommit = $self->_get_prop("last_commit");
1924 # Start exclusive lock here...
1925 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
1927 # TODO: log processing is memory bound
1928 # if we can parse into a 2nd file that is in reverse order
1929 # we can probably do something really efficient
1930 my @git_log_params = ('--parents', '--topo-order');
1932 if (defined $lastcommit) {
1933 push @git_log_params, "$lastcommit..$self->{module}";
1934 } else {
1935 push @git_log_params, $self->{module};
1936 }
1937 open(GITLOG, '-|', 'git-log', @git_log_params) or die "Cannot call git-log: $!";
1939 my @commits;
1941 my %commit = ();
1943 while ( <GITLOG> )
1944 {
1945 chomp;
1946 if (m/^commit\s+(.*)$/) {
1947 # on ^commit lines put the just seen commit in the stack
1948 # and prime things for the next one
1949 if (keys %commit) {
1950 my %copy = %commit;
1951 unshift @commits, \%copy;
1952 %commit = ();
1953 }
1954 my @parents = split(m/\s+/, $1);
1955 $commit{hash} = shift @parents;
1956 $commit{parents} = \@parents;
1957 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
1958 # on rfc822-like lines seen before we see any message,
1959 # lowercase the entry and put it in the hash as key-value
1960 $commit{lc($1)} = $2;
1961 } else {
1962 # message lines - skip initial empty line
1963 # and trim whitespace
1964 if (!exists($commit{message}) && m/^\s*$/) {
1965 # define it to mark the end of headers
1966 $commit{message} = '';
1967 next;
1968 }
1969 s/^\s+//; s/\s+$//; # trim ws
1970 $commit{message} .= $_ . "\n";
1971 }
1972 }
1973 close GITLOG;
1975 unshift @commits, \%commit if ( keys %commit );
1977 # Now all the commits are in the @commits bucket
1978 # ordered by time DESC. for each commit that needs processing,
1979 # determine whether it's following the last head we've seen or if
1980 # it's on its own branch, grab a file list, and add whatever's changed
1981 # NOTE: $lastcommit refers to the last commit from previous run
1982 # $lastpicked is the last commit we picked in this run
1983 my $lastpicked;
1984 my $head = {};
1985 if (defined $lastcommit) {
1986 $lastpicked = $lastcommit;
1987 }
1989 my $committotal = scalar(@commits);
1990 my $commitcount = 0;
1992 # Load the head table into $head (for cached lookups during the update process)
1993 foreach my $file ( @{$self->gethead()} )
1994 {
1995 $head->{$file->{name}} = $file;
1996 }
1998 foreach my $commit ( @commits )
1999 {
2000 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2001 if (defined $lastpicked)
2002 {
2003 if (!in_array($lastpicked, @{$commit->{parents}}))
2004 {
2005 # skip, we'll see this delta
2006 # as part of a merge later
2007 # warn "skipping off-track $commit->{hash}\n";
2008 next;
2009 } elsif (@{$commit->{parents}} > 1) {
2010 # it is a merge commit, for each parent that is
2011 # not $lastpicked, see if we can get a log
2012 # from the merge-base to that parent to put it
2013 # in the message as a merge summary.
2014 my @parents = @{$commit->{parents}};
2015 foreach my $parent (@parents) {
2016 # git-merge-base can potentially (but rarely) throw
2017 # several candidate merge bases. let's assume
2018 # that the first one is the best one.
2019 if ($parent eq $lastpicked) {
2020 next;
2021 }
2022 open my $p, 'git-merge-base '. $lastpicked . ' '
2023 . $parent . '|';
2024 my @output = (<$p>);
2025 close $p;
2026 my $base = join('', @output);
2027 chomp $base;
2028 if ($base) {
2029 my @merged;
2030 # print "want to log between $base $parent \n";
2031 open(GITLOG, '-|', 'git-log', "$base..$parent")
2032 or die "Cannot call git-log: $!";
2033 my $mergedhash;
2034 while (<GITLOG>) {
2035 chomp;
2036 if (!defined $mergedhash) {
2037 if (m/^commit\s+(.+)$/) {
2038 $mergedhash = $1;
2039 } else {
2040 next;
2041 }
2042 } else {
2043 # grab the first line that looks non-rfc822
2044 # aka has content after leading space
2045 if (m/^\s+(\S.*)$/) {
2046 my $title = $1;
2047 $title = substr($title,0,100); # truncate
2048 unshift @merged, "$mergedhash $title";
2049 undef $mergedhash;
2050 }
2051 }
2052 }
2053 close GITLOG;
2054 if (@merged) {
2055 $commit->{mergemsg} = $commit->{message};
2056 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2057 foreach my $summary (@merged) {
2058 $commit->{mergemsg} .= "\t$summary\n";
2059 }
2060 $commit->{mergemsg} .= "\n\n";
2061 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2062 }
2063 }
2064 }
2065 }
2066 }
2068 # convert the date to CVS-happy format
2069 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2071 if ( defined ( $lastpicked ) )
2072 {
2073 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2074 while ( <FILELIST> )
2075 {
2076 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)\s+(.*)$/o )
2077 {
2078 die("Couldn't process git-diff-tree line : $_");
2079 }
2081 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2083 my $git_perms = "";
2084 $git_perms .= "r" if ( $1 & 4 );
2085 $git_perms .= "w" if ( $1 & 2 );
2086 $git_perms .= "x" if ( $1 & 1 );
2087 $git_perms = "rw" if ( $git_perms eq "" );
2089 if ( $3 eq "D" )
2090 {
2091 #$log->debug("DELETE $4");
2092 $head->{$4} = {
2093 name => $4,
2094 revision => $head->{$4}{revision} + 1,
2095 filehash => "deleted",
2096 commithash => $commit->{hash},
2097 modified => $commit->{date},
2098 author => $commit->{author},
2099 mode => $git_perms,
2100 };
2101 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2102 }
2103 elsif ( $3 eq "M" )
2104 {
2105 #$log->debug("MODIFIED $4");
2106 $head->{$4} = {
2107 name => $4,
2108 revision => $head->{$4}{revision} + 1,
2109 filehash => $2,
2110 commithash => $commit->{hash},
2111 modified => $commit->{date},
2112 author => $commit->{author},
2113 mode => $git_perms,
2114 };
2115 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2116 }
2117 elsif ( $3 eq "A" )
2118 {
2119 #$log->debug("ADDED $4");
2120 $head->{$4} = {
2121 name => $4,
2122 revision => 1,
2123 filehash => $2,
2124 commithash => $commit->{hash},
2125 modified => $commit->{date},
2126 author => $commit->{author},
2127 mode => $git_perms,
2128 };
2129 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2130 }
2131 else
2132 {
2133 $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2134 die;
2135 }
2136 }
2137 close FILELIST;
2138 } else {
2139 # this is used to detect files removed from the repo
2140 my $seen_files = {};
2142 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2143 while ( <FILELIST> )
2144 {
2145 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2146 {
2147 die("Couldn't process git-ls-tree line : $_");
2148 }
2150 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2152 $seen_files->{$git_filename} = 1;
2154 my ( $oldhash, $oldrevision, $oldmode ) = (
2155 $head->{$git_filename}{filehash},
2156 $head->{$git_filename}{revision},
2157 $head->{$git_filename}{mode}
2158 );
2160 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2161 {
2162 $git_perms = "";
2163 $git_perms .= "r" if ( $1 & 4 );
2164 $git_perms .= "w" if ( $1 & 2 );
2165 $git_perms .= "x" if ( $1 & 1 );
2166 } else {
2167 $git_perms = "rw";
2168 }
2170 # unless the file exists with the same hash, we need to update it ...
2171 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2172 {
2173 my $newrevision = ( $oldrevision or 0 ) + 1;
2175 $head->{$git_filename} = {
2176 name => $git_filename,
2177 revision => $newrevision,
2178 filehash => $git_hash,
2179 commithash => $commit->{hash},
2180 modified => $commit->{date},
2181 author => $commit->{author},
2182 mode => $git_perms,
2183 };
2186 $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2187 }
2188 }
2189 close FILELIST;
2191 # Detect deleted files
2192 foreach my $file ( keys %$head )
2193 {
2194 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2195 {
2196 $head->{$file}{revision}++;
2197 $head->{$file}{filehash} = "deleted";
2198 $head->{$file}{commithash} = $commit->{hash};
2199 $head->{$file}{modified} = $commit->{date};
2200 $head->{$file}{author} = $commit->{author};
2202 $db_insert_rev->execute($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2203 }
2204 }
2205 # END : "Detect deleted files"
2206 }
2209 if (exists $commit->{mergemsg})
2210 {
2211 $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2212 }
2214 $lastpicked = $commit->{hash};
2216 $self->_set_prop("last_commit", $commit->{hash});
2217 }
2219 $db_delete_head->execute();
2220 foreach my $file ( keys %$head )
2221 {
2222 $db_insert_head->execute(
2223 $file,
2224 $head->{$file}{revision},
2225 $head->{$file}{filehash},
2226 $head->{$file}{commithash},
2227 $head->{$file}{modified},
2228 $head->{$file}{author},
2229 $head->{$file}{mode},
2230 );
2231 }
2232 # invalidate the gethead cache
2233 $self->{gethead_cache} = undef;
2236 # Ending exclusive lock here
2237 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2238 }
2240 sub _headrev
2241 {
2242 my $self = shift;
2243 my $filename = shift;
2245 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2246 $db_query->execute($filename);
2247 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2249 return ( $hash, $revision, $mode );
2250 }
2252 sub _get_prop
2253 {
2254 my $self = shift;
2255 my $key = shift;
2257 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2258 $db_query->execute($key);
2259 my ( $value ) = $db_query->fetchrow_array;
2261 return $value;
2262 }
2264 sub _set_prop
2265 {
2266 my $self = shift;
2267 my $key = shift;
2268 my $value = shift;
2270 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2271 $db_query->execute($value, $key);
2273 unless ( $db_query->rows )
2274 {
2275 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2276 $db_query->execute($key, $value);
2277 }
2279 return $value;
2280 }
2282 =head2 gethead
2284 =cut
2286 sub gethead
2287 {
2288 my $self = shift;
2290 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2292 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head",{},1);
2293 $db_query->execute();
2295 my $tree = [];
2296 while ( my $file = $db_query->fetchrow_hashref )
2297 {
2298 push @$tree, $file;
2299 }
2301 $self->{gethead_cache} = $tree;
2303 return $tree;
2304 }
2306 =head2 getlog
2308 =cut
2310 sub getlog
2311 {
2312 my $self = shift;
2313 my $filename = shift;
2315 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2316 $db_query->execute($filename);
2318 my $tree = [];
2319 while ( my $file = $db_query->fetchrow_hashref )
2320 {
2321 push @$tree, $file;
2322 }
2324 return $tree;
2325 }
2327 =head2 getmeta
2329 This function takes a filename (with path) argument and returns a hashref of
2330 metadata for that file.
2332 =cut
2334 sub getmeta
2335 {
2336 my $self = shift;
2337 my $filename = shift;
2338 my $revision = shift;
2340 my $db_query;
2341 if ( defined($revision) and $revision =~ /^\d+$/ )
2342 {
2343 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2344 $db_query->execute($filename, $revision);
2345 }
2346 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2347 {
2348 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2349 $db_query->execute($filename, $revision);
2350 } else {
2351 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2352 $db_query->execute($filename);
2353 }
2355 return $db_query->fetchrow_hashref;
2356 }
2358 =head2 commitmessage
2360 this function takes a commithash and returns the commit message for that commit
2362 =cut
2363 sub commitmessage
2364 {
2365 my $self = shift;
2366 my $commithash = shift;
2368 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2370 my $db_query;
2371 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2372 $db_query->execute($commithash);
2374 my ( $message ) = $db_query->fetchrow_array;
2376 if ( defined ( $message ) )
2377 {
2378 $message .= " " if ( $message =~ /\n$/ );
2379 return $message;
2380 }
2382 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2383 shift @lines while ( $lines[0] =~ /\S/ );
2384 $message = join("",@lines);
2385 $message .= " " if ( $message =~ /\n$/ );
2386 return $message;
2387 }
2389 =head2 gethistory
2391 This function takes a filename (with path) argument and returns an arrayofarrays
2392 containing revision,filehash,commithash ordered by revision descending
2394 =cut
2395 sub gethistory
2396 {
2397 my $self = shift;
2398 my $filename = shift;
2400 my $db_query;
2401 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2402 $db_query->execute($filename);
2404 return $db_query->fetchall_arrayref;
2405 }
2407 =head2 gethistorydense
2409 This function takes a filename (with path) argument and returns an arrayofarrays
2410 containing revision,filehash,commithash ordered by revision descending.
2412 This version of gethistory skips deleted entries -- so it is useful for annotate.
2413 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2414 and other git tools that depend on it.
2416 =cut
2417 sub gethistorydense
2418 {
2419 my $self = shift;
2420 my $filename = shift;
2422 my $db_query;
2423 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2424 $db_query->execute($filename);
2426 return $db_query->fetchall_arrayref;
2427 }
2429 =head2 in_array()
2431 from Array::PAT - mimics the in_array() function
2432 found in PHP. Yuck but works for small arrays.
2434 =cut
2435 sub in_array
2436 {
2437 my ($check, @array) = @_;
2438 my $retval = 0;
2439 foreach my $test (@array){
2440 if($check eq $test){
2441 $retval = 1;
2442 }
2443 }
2444 return $retval;
2445 }
2447 =head2 safe_pipe_capture
2449 an alterative to `command` that allows input to be passed as an array
2450 to work around shell problems with weird characters in arguments
2452 =cut
2453 sub safe_pipe_capture {
2455 my @output;
2457 if (my $pid = open my $child, '-|') {
2458 @output = (<$child>);
2459 close $child or die join(' ',@_).": $! $?";
2460 } else {
2461 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2462 }
2463 return wantarray ? @output : join('',@output);
2464 }
2467 1;