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.
22 use File::Temp qw/tempdir tempfile/;
25 my $log = GITCVS::log->new();
43 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
46 #### Definition and mappings of functions ####
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,
61 'remove' => \&req_remove,
63 'update' => \&req_update,
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,
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.
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
95 # Check to see if we've seen this method, and call appropiate function.
96 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
98 # use the $methods hash to call the appropriate sub for this command
99 #$log->info("Method : $1");
100 &{$methods->{$1}}($1,$2);
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 $_");
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.
120 my ( $cmd, $data ) = @_;
121 $log->warn("Unhandled command : req_$cmd : $data");
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.
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` )
145 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
149 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
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";
154 print "error 1 GITCVS emulation disabled\n";
157 if ( defined ( $cfg->{gitcvs}{logfile} ) )
159 $log->setfile($cfg->{gitcvs}{logfile});
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
174 my ( $cmd, $data ) = @_;
175 $log->debug("req_Globaloption : $data");
177 # TODO : is this data useful ???
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
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 ];
193 # Response expected: yes. Ask the server to send back a Valid-requests
195 sub req_validrequests
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";
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
221 my ( $cmd, $data ) = @_;
223 my $repository = <STDIN>;
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}");
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
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],
260 tag_or_date => $data[5],
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.
272 my ( $cmd, $data ) = @_;
278 foreach my $filename ( @{$state->{args}} )
280 $filename = filecleanup($filename);
282 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
284 print "E cvs add: nothing known about `$filename'\n";
287 # TODO : check we're not squashing an already existing file
288 if ( defined ( $state->{entries}{$filename}{revision} ) )
290 print "E cvs add: `$filename' has already been entered\n";
295 my ( $filepart, $dirpart ) = filenamesplit($filename);
297 print "E cvs add: scheduling file `$filename' for addition\n";
299 print "Checked-in $dirpart\n";
301 print "/$filepart/0///\n";
306 if ( $addcount == 1 )
308 print "E cvs add: use `cvs commit' to add this file permanently\n";
310 elsif ( $addcount > 1 )
312 print "E cvs add: use `cvs commit' to add these files permanently\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.
331 my ( $cmd, $data ) = @_;
335 # Grab a handle to the SQLite db and do any necessary updates
336 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
339 #$log->debug("add state : " . Dumper($state));
343 foreach my $filename ( @{$state->{args}} )
345 $filename = filecleanup($filename);
347 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
349 print "E cvs remove: file `$filename' still in working directory\n";
353 my $meta = $updater->getmeta($filename);
354 my $wrev = revparse($filename);
356 unless ( defined ( $wrev ) )
358 print "E cvs remove: nothing known about `$filename'\n";
362 if ( defined($wrev) and $wrev < 0 )
364 print "E cvs remove: file `$filename' already scheduled for removal\n";
368 unless ( $wrev == $meta->{revision} )
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";
376 my ( $filepart, $dirpart ) = filenamesplit($filename);
378 print "E cvs remove: scheduling `$filename' for removal\n";
380 print "Checked-in $dirpart\n";
382 print "/$filepart/-1.$wrev///\n";
389 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
391 elsif ( $rmcount > 1 )
393 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
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.
408 my ( $cmd, $data ) = @_;
415 # Grab config information
416 my $blocksize = 8192;
417 my $bytesleft = $size;
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.
426 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
427 read STDIN, $tmp, $blocksize;
429 $bytesleft -= $blocksize;
434 # Ensure we have something sensible for the file mode
435 if ( $mode =~ /u=(\w+)/ )
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");
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 `/'.
457 my ( $cmd, $data ) = @_;
459 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
461 #$log->debug("req_Unchanged : $data");
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.
473 my ( $cmd, $data ) = @_;
475 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
477 #$log->debug("req_Questionable : $data");
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.
485 # Response expected: no. Append \n followed by text to the current argument
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;
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
523 my ( $cmd, $data ) = @_;
527 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
529 unless ( ref $state->{arguments} eq "ARRAY" )
535 foreach my $module ( @{$state->{arguments}} )
537 $log->debug("SEND : Module-expansion $module");
538 print "Module-expansion $module\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.
554 my ( $cmd, $data ) = @_;
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);
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} )
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 "./" )
592 print "MT fname $checkout_path/$git->{dir}$git->{name}\n";
594 print "MT fname $checkout_path/$git->{name}\n";
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";
607 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
610 transmitfile($git->{filehash});
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.
627 my ( $cmd, $data ) = @_;
629 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
633 # Grab a handle to the SQLite db and do any necessary updates
634 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
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}} )
646 $filename = filecleanup($filename);
648 # if we have a -C we should pretend we never saw modified stuff
649 if ( exists ( $state->{opt}{C} ) )
651 delete $state->{entries}{$filename}{modified_hash};
652 delete $state->{entries}{$filename}{modified_filename};
653 $state->{entries}{$filename}{unchanged} = 1;
657 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
659 $meta = $updater->getmeta($filename, $1);
661 $meta = $updater->getmeta($filename);
664 next unless ( $meta->{revision} );
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} )
673 $oldmeta = $updater->getmeta($filename, $wrev);
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" )
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";
691 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} ) or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
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";
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 ) )
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'");
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'");
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";
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";
725 transmitfile($meta->{filehash});
727 my ( $filepart, $dirpart ) = filenamesplit($meta->{name});
729 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
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);
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";
758 elsif ( $return == 1 )
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";
768 $log->warn("Merge failed");
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";
794 my ( $cmd, $data ) = @_;
798 #$log->debug("State : " . Dumper($state));
800 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
802 if ( -e $state->{CVSROOT} . "/index" )
804 print "error 1 Index already exists in git repo\n";
808 my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
809 unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
811 print "error 1 Lock file '$lockfile' already exists, please try again\n";
815 # Grab a handle to the SQLite db and do any necessary updates
816 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
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;
828 # populate the temporary index based
829 system("git-read-tree", $state->{module});
832 die "Error running git-read-tree $state->{module} $file_index $!";
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}} )
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
854 system('git-checkout-index', '-f', '-u', $filename);
856 die "Error running git-checkout-index -f -u $filename : $!";
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} ) )
868 # fail everything if an up to date check fails
869 print "error 1 Up to date check failed for $filename\n";
876 push @committedfiles, $filename;
877 $log->info("Committing $filename");
879 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
883 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
884 rename $state->{entries}{$filename}{modified_filename},$filename;
886 # Calculate modes to remove
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);
896 $log->info("Removing file '$filename'");
898 system("git-update-index", "--remove", $filename);
902 $log->info("Adding file '$filename'");
903 system("git-update-index", "--add", $filename);
905 $log->info("Updating file '$filename'");
906 system("git-update-index", $filename);
910 unless ( scalar(@committedfiles) > 0 )
912 print "E No files to commit\n";
920 my $treehash = `git-write-tree`;
921 my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
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";
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}/ )
938 $log->warn("Commit failed (Invalid commit hash)");
939 print "error 1 Commit failed (unknown reason)\n";
946 open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
947 print FILE $commithash;
952 # foreach file specified on the commandline ...
953 foreach my $filename ( @committedfiles )
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" )
965 print "Remove-entry $dirpart\n";
968 print "Checked-in $dirpart\n";
970 print "/$filepart/1.$meta->{revision}///\n";
983 my ( $cmd, $data ) = @_;
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);
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}} )
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} )
1010 $oldmeta = $updater->getmeta($filename, $wrev);
1013 # TODO : All possible statuses aren't yet implemented
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}
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} ) )
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
1025 ( $state->{entries}{$filename}{unchanged}
1026 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
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}) )
1049 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1051 print "M Working revision:\tNo entry for $filename\n";
1053 if ( defined($meta->{revision}) )
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";
1060 print "M Repository revision:\tNo revision control file\n";
1070 my ( $cmd, $data ) = @_;
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" )
1080 $revision1 = $state->{opt}{r}[0];
1081 $revision2 = $state->{opt}{r}[1];
1083 $revision1 = $state->{opt}{r};
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);
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}} )
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 ) )
1113 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1114 $meta1 = $updater->getmeta($filename, $revision1);
1115 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1117 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1120 transmitfile($meta1->{filehash}, $file1);
1122 # otherwise we just use the working copy revision
1125 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1126 $meta1 = $updater->getmeta($filename, $wrev);
1127 transmitfile($meta1->{filehash}, $file1);
1130 # if we have a second -r switch, use it too
1131 if ( defined ( $revision2 ) )
1133 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1134 $meta2 = $updater->getmeta($filename, $revision2);
1136 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1138 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1142 transmitfile($meta2->{filehash}, $file2);
1144 # otherwise we just use the working copy
1147 $file2 = $state->{entries}{$filename}{modified_filename};
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 ) )
1153 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1154 $meta2 = $updater->getmeta($filename, $wrev);
1155 transmitfile($meta2->{filehash}, $file2);
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}
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} ) )
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 ) );
1177 foreach my $opt ( keys %{$state->{opt}} )
1179 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1181 foreach my $value ( @{$state->{opt}{$opt}} )
1183 print "-$opt $value ";
1187 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
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} )
1198 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1200 system("diff $file1 $file2 > $filediff");
1215 my ( $cmd, $data ) = @_;
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.]+)?/ )
1228 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1229 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1230 $minrev++ if ( defined($minrev) and $control eq "::" );
1233 # Grab a handle to the SQLite db and do any necessary updates
1234 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
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}} )
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 ) )
1252 $log->debug("Removing revisions less than $minrev");
1253 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1258 if ( defined ( $maxrev ) )
1260 $log->debug("Removing revisions greater than $maxrev");
1261 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1267 next unless ( scalar(@$revisions) );
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 )
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";
1294 print "M =============================================================================\n";
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);
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;
1326 # foreach file specified on the commandline ...
1327 foreach my $filename ( @{$state->{args}} )
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);
1348 die "Error running git-read-tree $lastseenin $file_index $!";
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);
1355 die "Error running git-checkout-index -f -u $filename : $!";
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
1365 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1366 for (my $i=0; $i < @$revisions; $i++)
1368 print ANNOTATEHINTS $revisions->[$i][2];
1369 if ($i+1 < @$revisions) { # have we got a parent?
1370 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1372 print ANNOTATEHINTS "\n";
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 : $!";
1382 print "E Annotations for $filename\n";
1383 print "E ***************\n";
1384 while ( <ANNOTATE> )
1386 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1388 my $commithash = $1;
1390 unless ( defined ( $metadata->{$commithash} ) )
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)/ );
1397 printf("M 1.%-5d (%-8s %10s): %s\n",
1398 $metadata->{$commithash}{revision},
1399 $metadata->{$commithash}{author},
1400 $metadata->{$commithash}{modified},
1404 $log->warn("Error in annotate output! LINE: $_");
1405 print "E Annotate error \n";
1412 # done; get out of the tempdir
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.
1424 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1428 $state->{args} = [];
1429 $state->{files} = [];
1432 if ( defined($type) )
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 )
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)(.*)/ )
1455 # if it's a switch that takes an argument
1458 # If this switch has already been provided
1459 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1461 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1462 if ( length($2) > 0 )
1464 push @{$state->{opt}{$1}},$2;
1466 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1469 # if there's extra data in the arg, use that as the argument for the switch
1470 if ( length($2) > 0 )
1472 $state->{opt}{$1} = $2;
1474 $state->{opt}{$1} = shift @{$state->{arguments}};
1478 $state->{opt}{$1} = undef;
1483 push @{$state->{args}}, $arg;
1491 foreach my $value ( @{$state->{arguments}} )
1493 if ( $value eq "--" )
1498 push @{$state->{args}}, $value if ( $mode == 0 );
1499 push @{$state->{files}}, $value if ( $mode == 1 );
1504 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1507 my $updater = shift;
1509 $state->{args} = [];
1511 foreach my $file ( @{$updater->gethead} )
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};
1519 # This method cleans up the $state variable after a command that uses arguments has run
1522 $state->{files} = [];
1523 $state->{args} = [];
1524 $state->{arguments} = [];
1525 $state->{entries} = {};
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+)/ );
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
1546 my $filehash = shift;
1547 my $targetfile = shift;
1549 if ( defined ( $filehash ) and $filehash eq "deleted" )
1551 $log->warn("filehash is 'deleted'");
1555 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1557 my $type = `git-cat-file -t $filehash`;
1560 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1562 my $size = `git-cat-file -s $filehash`;
1565 $log->debug("transmitfile($filehash) size=$size, type=$type");
1567 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1569 if ( defined ( $targetfile ) )
1571 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1572 print NEWFILE $_ while ( <$fh> );
1576 print while ( <$fh> );
1578 close $fh or die ("Couldn't close filehandle for transmitfile()");
1580 die("Couldn't execute git-cat-file");
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
1589 my $filename = shift;
1591 my ( $filepart, $dirpart ) = ( $filename, "." );
1592 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1595 return ( $filepart, $dirpart );
1600 my $filename = shift;
1602 return undef unless(defined($filename));
1603 if ( $filename =~ /^\// )
1605 print "E absolute filenames '$filename' not supported by server\n";
1609 $filename =~ s/^\.\///g;
1610 $filename = $state->{directory} . $filename;
1615 package GITCVS::log;
1618 #### Copyright The Open University UK - 2006.
1620 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1621 #### Martin Langhoff <martin@catalyst.net.nz>
1634 This module provides very crude logging with a similar interface to
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
1648 Until one of these methods is called, all log calls will buffer messages ready
1655 my $filename = shift;
1659 bless $self, $class;
1661 if ( defined ( $filename ) )
1663 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
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.
1679 my $filename = shift;
1681 if ( defined ( $filename ) )
1683 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1686 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1688 while ( my $line = shift @{$self->{buffer}} )
1690 print {$self->{fh}} $line;
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.
1706 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1708 $self->{buffer} = [];
1713 Internal method. Returns true if the log file is open, false otherwise.
1720 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1724 =head2 debug info warn fatal
1726 These four methods are wrappers to _log. They provide the actual interface for
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", @_); }
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.
1746 return if ( $self->{nolog} );
1748 my @time = localtime;
1749 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1759 if ( $self->_logopen )
1761 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1763 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1769 This method simply closes the file handle if one is open
1776 if ( $self->_logopen )
1782 package GITCVS::updater;
1785 #### Copyright The Open University UK - 2006.
1787 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1788 #### Martin Langhoff <martin@catalyst.net.nz>
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;
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 )
1838 $self->{tables}{$table} = 1;
1841 # Construct the revision table if required
1842 unless ( $self->{tables}{revision} )
1845 CREATE TABLE revision (
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,
1857 # Construct the revision table if required
1858 unless ( $self->{tables}{head} )
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,
1873 # Construct the properties table if required
1874 unless ( $self->{tables}{properties} )
1877 CREATE TABLE properties (
1878 key TEXT NOT NULL PRIMARY KEY,
1884 # Construct the commitmsgs table if required
1885 unless ( $self->{tables}{commitmsgs} )
1888 CREATE TABLE commitmsgs (
1889 key TEXT NOT NULL PRIMARY KEY,
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}/ )
1917 die("Invalid module '$self->{module}'");
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}";
1935 push @git_log_params, $self->{module};
1937 open(GITLOG, '-|', 'git-log', @git_log_params) or die "Cannot call git-log: $!";
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
1951 unshift @commits, \%copy;
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;
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} = '';
1969 s/^\s+//; s/\s+$//; # trim ws
1970 $commit{message} .= $_ . "\n";
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
1985 if (defined $lastcommit) {
1986 $lastpicked = $lastcommit;
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()} )
1995 $head->{$file->{name}} = $file;
1998 foreach my $commit ( @commits )
2000 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2001 if (defined $lastpicked)
2003 if (!in_array($lastpicked, @{$commit->{parents}}))
2005 # skip, we'll see this delta
2006 # as part of a merge later
2007 # warn "skipping off-track $commit->{hash}\n";
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) {
2022 open my $p, 'git-merge-base '. $lastpicked . ' '
2024 my @output = (<$p>);
2026 my $base = join('', @output);
2030 # print "want to log between $base $parent \n";
2031 open(GITLOG, '-|', 'git-log', "$base..$parent")
2032 or die "Cannot call git-log: $!";
2036 if (!defined $mergedhash) {
2037 if (m/^commit\s+(.+)$/) {
2043 # grab the first line that looks non-rfc822
2044 # aka has content after leading space
2045 if (m/^\s+(\S.*)$/) {
2047 $title = substr($title,0,100); # truncate
2048 unshift @merged, "$mergedhash $title";
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";
2060 $commit->{mergemsg} .= "\n\n";
2061 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
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 ) )
2073 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2074 while ( <FILELIST> )
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 )
2078 die("Couldn't process git-diff-tree line : $_");
2081 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
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 "" );
2091 #$log->debug("DELETE $4");
2094 revision => $head->{$4}{revision} + 1,
2095 filehash => "deleted",
2096 commithash => $commit->{hash},
2097 modified => $commit->{date},
2098 author => $commit->{author},
2101 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2105 #$log->debug("MODIFIED $4");
2108 revision => $head->{$4}{revision} + 1,
2110 commithash => $commit->{hash},
2111 modified => $commit->{date},
2112 author => $commit->{author},
2115 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2119 #$log->debug("ADDED $4");
2124 commithash => $commit->{hash},
2125 modified => $commit->{date},
2126 author => $commit->{author},
2129 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2133 $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
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> )
2145 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2147 die("Couldn't process git-ls-tree line : $_");
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}
2160 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2163 $git_perms .= "r" if ( $1 & 4 );
2164 $git_perms .= "w" if ( $1 & 2 );
2165 $git_perms .= "x" if ( $1 & 1 );
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 )
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},
2186 $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2191 # Detect deleted files
2192 foreach my $file ( keys %$head )
2194 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
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});
2205 # END : "Detect deleted files"
2209 if (exists $commit->{mergemsg})
2211 $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2214 $lastpicked = $commit->{hash};
2216 $self->_set_prop("last_commit", $commit->{hash});
2219 $db_delete_head->execute();
2220 foreach my $file ( keys %$head )
2222 $db_insert_head->execute(
2224 $head->{$file}{revision},
2225 $head->{$file}{filehash},
2226 $head->{$file}{commithash},
2227 $head->{$file}{modified},
2228 $head->{$file}{author},
2229 $head->{$file}{mode},
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";
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 );
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;
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 )
2275 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2276 $db_query->execute($key, $value);
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();
2296 while ( my $file = $db_query->fetchrow_hashref )
2301 $self->{gethead_cache} = $tree;
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);
2319 while ( my $file = $db_query->fetchrow_hashref )
2329 This function takes a filename (with path) argument and returns a hashref of
2330 metadata for that file.
2337 my $filename = shift;
2338 my $revision = shift;
2341 if ( defined($revision) and $revision =~ /^\d+$/ )
2343 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2344 $db_query->execute($filename, $revision);
2346 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2348 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2349 $db_query->execute($filename, $revision);
2351 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2352 $db_query->execute($filename);
2355 return $db_query->fetchrow_hashref;
2358 =head2 commitmessage
2360 this function takes a commithash and returns the commit message for that commit
2366 my $commithash = shift;
2368 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
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 ) )
2378 $message .= " " if ( $message =~ /\n$/ );
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$/ );
2391 This function takes a filename (with path) argument and returns an arrayofarrays
2392 containing revision,filehash,commithash ordered by revision descending
2398 my $filename = shift;
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;
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.
2420 my $filename = shift;
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;
2431 from Array::PAT - mimics the in_array() function
2432 found in PHP. Yuck but works for small arrays.
2437 my ($check, @array) = @_;
2439 foreach my $test (@array){
2440 if($check eq $test){
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
2453 sub safe_pipe_capture {
2457 if (my $pid = open my $child, '-|') {
2458 @output = (<$child>);
2459 close $child or die join(' ',@_).": $! $?";
2461 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2463 return wantarray ? @output : join('',@output);